Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM M1 M M2 O^TEXT{" PB2.41.TEXT{" PB2.42.TEXT{" PB2.43.TEXT{"PB1.2.TEXTS{­{" PB2.22.TEXT{" PB2.23.TEXT{" PB2.24.TEXT{"PB2.25+26.TEXT{" PB2.29.TEXT{"PB2.31+32.TEXT{"PB2.33-36.TEXT{" PB2.37.TEXT{" PB2.38.TEXT{" PB2.39. BILD.D.FOTOvg LIESMICH.TEXT{ SCHRAEG.TEXTf JUZOOM.TEXTf APZOOM.TEXTf HCIMAGE.TEXTvgrHCIMAGE.TEXTvgFUER.C.M.TEXT{ PB2.20.TEXT{" PB2.21.TEXTTEXTE2S PB2.42.TEXT{( PB2.43.TEXT{(L PB3.1.TEXTS{Lb PB3.2.TEXT=vgbr PB3.3.TEXT=vgrvSLIDESHOW.CODEgv BILD.A.FOTOvg BILD.B.FOTOvg BILD.C.FOTOvg&꽌ɪɖ'*&%&,E'зЮ꽌ɪФ`+*xH&x'8*7Ixix&&  ') + &п x) ++`FG8`0($ p,&"auf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30 auf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30  (* Programmbeispiel 2.42 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " PROGRAM apfelmaennchen_auf_Diskette; 11.11" *) "(* imaginaerer Ber.: 2.016 Einheiten auf 8" *) & &wiederholung := 100; "(* Wiederholungen , bei 50 : ca. 36 Stunden *) "(* bei 100 : ca. 72 Stunden *) & &grenze := 100; "(* Abfragegrenze fuer28,8 cm --> DIN A 4 *) "(* 72 --> quadratisches Bild *) & &faktory := punkte/((rechts-links)*64/(anzahl/9)); "(* so erreicht man gleichen Massstab in beiden Richtungen, z.B. *) "(* reeller Bereich : 2.8 Einheiten auf "(* 576 & 'n' , 640 & 'N' , 768 & 'E' , 960 & 'q' *) "(* 1088 & 'Q' , 1152 & 'p' , 1280 & 'P' *) & &punkte := 576; &punkt := punkte DIV 2; & &anzahl := 8 * 72 (* 72 *); "(* Anzahl der Zeilen, 102 --> 11.3 " = it *) ( ( $PROCEDURE eingabe; $BEGIN &links := -1.0; &rechts := 2.5; "(* oben und unten entfallen *) & &steuerzeichen := 'n'; "(* andere Kombinationen sind beim APPLE DMP : *) chr(ord('0') + zaehler + 7) .ELSE .IF zaehler < 62 THEN 0chartable[zaehler] := chr(ord('0') + zaehler + 13) 0ELSE 0IF Zaehler = 62 THEN 2chartable[zaehler] := '>' 2ELSE 2IF zaehler = 63 THEN 4chartable[zaehler] := '?' (END; $END; (* von tablein"(* die look-up-table fuer die Chiffrierung wird erstellt *) &VAR (zaehler : integer; $BEGIN &FOR zaehler := 0 TO 63 DO (BEGIN *IF zaehler<10 THEN ,chartable[zaehler] := chr(ord('0') + zaehler) ,ELSE ,IF zaehler < 36 THEN .chartable[zaehler] := "(* Laufzeitfehler (floating-point errors) zu vermeiden. *) & &xhoch2 := x * x; &yhoch2 := y * y; &quadr := xhoch2 + yhoch2; &schleifenzaehler := succ(schleifenzaehler); &fertig := (quadr > grenze); $END; (* von f *) $ $ $PROCEDURE tableinit; stante abziehen *) $BEGIN &y := 2.0*x*y - y_komplex; &x := xhoch2 - yhoch2 - x_komplex; &IF (abs(x) <1E-15) THEN x := 0.0; &IF (abs(y) <1E-15) THEN y := 0.0; "(* diese beiden Abfragen sind notwendig, um *) HEN (WHILE zahl < 0.1 DO BEGIN *zahl := 10 * zahl; *szwisch := concat(szwisch,'0'); (END ELSE zahl := 0; &str(round(10000*zahl),shinter); & &st := concat(svor,szwisch,shinter); $END; (* von realstring *) $ $ $PROCEDURE f; "(* quadrieren und Konnter := ' '; &nachkomma := true; & &WHILE (abs(zahl) > maxint) DO BEGIN (zahl := zahl / 10.0; (nachkomma := false; (szwisch := concat('0',szwisch); &END; &str(trunc(zahl),svor); & &zahl := abs(zahl - trunc(zahl)); &IF (zahl > 0) AND nachkomma T$END; (* von keypress *) $ $ $PROCEDURE realstr (zahl : real; VAR st : string); "(* wandelt real-Zahl in String *) " &VAR (nachkomma : boolean; (svor,szwisch,shinter : string; $BEGIN &svor := ' '; &szwisch := '.'; &shiess : boolean; "(* erspart den Aufruf von APPLESTUFF *) $ &VAR rec : RECORD 2number: integer 0END; *par : PACKED ARRAY[0..0] OF char; $BEGIN &par[0] := chr(0); &unitwrite(1,par,1); &unitstatus(1,rec,1); &keypress := (rec.number > 0) lean; &links,rechts,grenze,faktory, &xwert,dx,x,y,xhoch2,y_komplex, &yhoch2,x_komplex,quadr : real; &outfile : text; &chartable : tablechar; &punktstring,filename : string[19]; $ $ $FUNCTION keypr" $CONST &maxpunkte = 1280; $ $TYPE &tablechar = ARRAY [0..63] OF char; $ $VAR &punkte,punkt,anzahl, &rausgabe,schleifenzaehler, &wiederholung,zaehler1 : integer; &esc,steuerzeichen,ch,symm : char; &fertig,ersterwert : boo f-Quadrat *) & &symm := 'x'; "(* Symmetrie : x,y fuer die jeweiligen Achsen, *) "(* z fuer beide, s fuer Punktsymm, 0 fuer keine *) & &dx := (rechts-links)/anzahl; $END; (* von Eingabe *) $ " $PROCEDURE berechne; "(* hier passiert die eigentliche Arbeit *) &VAR (merker,altwert,zaehl4,zaehl5,zaehl6 : integer; $ &PROCEDURE rechne (VAR wert : integer); "(* wiederholt f bis Grenze erreicht, hoechstens 100 mal *) &BEGIN (x:=0.0;y:=0.0; (xhoch2 := x*x; (yhoch2 Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM M1 M2 M m]O^*) $BEGIN &close(outfile,lock); $END; (* von beende *) $ $ "BEGIN (* Hauptprogramm *) $eingabe; $tableinit; $haeder; $berechne; $beende; "END. (* Hauptprogramm *) " tfile,filename); &write(outfile,filename,' ',symm,' ',stanz,' ',stpunkt,' '); &realstr(links,stout); write(outfile,stout,' '); &realstr(rechts,stout); write(outfile,stout,' '); $END; (* von header *) $ $ $PROCEDURE beende; "(* schliesst das File (IF pos(filename,'.DATA') = 0 THEN *filename := concat(filename,'.DATA'); (IF length(filename) > 15 THEN *delete(filename,10,length(filename) - 15); "(* jetzt entspricht der Filename der Norm *) & &str(anzahl,stanz); str(punkt,stpunkt); &rewrite(ouanz,stout,stpunkt : string; $BEGIN &write('Name des Files > '); &readln(filename); &FOR zaehler1 := 1 TO length(filename) DO *IF filename[zaehler1] IN ['a'..'z'] THEN ,filename[zaehler1] := chr(ord(filename[zaehler1]) - 32); trolliert beenden *) &IF schleifenzaehler > 0 THEN rausdamit(schleifenzaehler - 1) (ELSE rausdamit(schleifenzaehler + 1); $END; (* von berechne *) & & $PROCEDURE haeder; "(* schreibt vor Beginn der Daten wichtige Informationen auf Disk *) &VAR (stplex >= 0 ) ,AND (x_komplex*x_komplex + y_komplex*y_komplex < 0.45) ,THEN rausdamit(63) "(* dirty trick um Arbeit und Zeit zu sparen *) ,ELSE BEGIN .rechne(schleifenzaehler); .rausdamit(schleifenzaehler); ,END; (END; &END; & "(* jetzt noch kon&y_komplex := 0; &rechne(altwert); "(* Damit sind die Anfangswerte gesetzt *) & &FOR zaehl5 := 0 TO anzahl DO BEGIN (writeln(zaehl5:6); (FOR zaehl6 := 0 TO punkt-1 DO BEGIN *x_komplex := rechts - zaehl5*dx; *y_komplex := zaehl6/faktory; *IF (xkom094; ,write(outfile,chartable[merker DIV 64], 4chartable[merker MOD 64], 4chartable[altwert]); ,merker := 1; *END; &END; (* von rausdamit *) & $BEGIN (* von berechne *) &merker := 0; &schleifenzaehler := 0; &x_komplex := rechts; ette *) &BEGIN (IF wert = altwert THEN merker := succ(merker) *ELSE BEGIN ,write(outfile,chartable[merker DIV 64], 4chartable[merker MOD 64], 4chartable[altwert]); ,merker := 1; ,altwert := wert; *END; (IF merker = 4095 THEN *BEGIN ,merker := 4:= y*y; (wert := 0; (REPEAT *f (UNTIL (wert = wiederholung) OR fertig; (IF (wert = wiederholung) THEN wert := 63 *ELSE IF wert > 20 THEN wert := 20; &END; (* von rechne *) & &PROCEDURE rausdamit (wert : integer); "(* schreibt ggf. etwas auf Diskauf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30  (* Programmbeispiel 2.43 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " PROGRAM vom_file_auf_den_drucker;  punkte+2,chr(0));  (* die schnellste Methode, das ARRAY zu loeschen *) 4 $zaehl1 := 1; zaehl2 := 0; $WHILE NOT eof(f) DO &BEGIN (herdamit(wert,farbe);  { writeln(wert:6,farbe:6); } (FOR zaehl3 := 1 TO wert DO *BEGIN  CASE artundwe;  (* z.B. ESC P --> 1280 dots/line *) $ $wr(esc); wr('>');  (* unidirektionaler Druck *) $ $wr(esc); wr('T'); wr('1'); wr('6');  (* 16/144 = 1/9" Zeilenvorschub *) $ $wr(chr(13)); wr(chr(10));  (* Zeilenvorschub *)  $fillchar(zeile,2*(zeile2[punkt-x_koordinate].bit[y_koordinate DIV 2]:=true;  END;  (* das Bild ist symmetrisch zur rellen Achse *) $END; & "BEGIN $  (* Festlegung der Druckersteuerzeichen *)  $esc := chr(27); $wr(esc); wr(steuerzeichen) THEN BEGIN (zeile[punkt+x_koordinate].bit[y_koordinate DIV 2 + 1]:=true; (zeile[punkt-x_koordinate].bit[y_koordinate DIV 2 + 1]:=true;  END ELSE BEGIN (zeile2[punkt+x_koordinate].bit[y_koordinate DIV 2]:=true; 4095 THEN wert := 4094;  (* dies korrigiert einen Fehler in "schreib" *)  &farbe := werttable[dritter]; $END; $ $PROCEDURE setzepunkt(x_koordinate,y_koordinate:integer); $BEGIN  { writeln(x_koordinate:8,y_koordinate:8); } &IF odd(y_koordinate)ehl2,zaehl3,zaehl4 : integer; " $PROCEDURE herdamit (VAR wert,farbe : integer); $ VAR (erster,zweiter,dritter : char; $BEGIN $ read(f,erster); &read(f,zweiter); &read(f,dritter); &wert := 64 * werttable[erster] + werttable[zweiter]; &IF wert = { writeln(bh); } $unitwrite(6,bh,1,0,12); "END;  (* Direkte Ansteuerung des Druckers. *)  (* Mit dieser Methode kann z.B. auch char(16) *)  (* problemlos an den Drucker gesandt werden. *) " " " "PROCEDURE bearbeite; " $VAR &zaehl1,za.0] OF char; "BEGIN $par[0] := chr(0); $unitwrite(1,par,1); $unitstatus(1,rec,1); $keypress := (rec.number > 0) "END;  (* erspart den Aufruf von APPLESTUFF *) "  "PROCEDURE wr(ch : char); $VAR bh : tbytes; "BEGIN $bh := ord(ch) MOD 256; N 0werttable[zaehler] := 62 0ELSE 0IF zaehler = '?' THEN 2werttable[zaehler] := 63 & ELSE werttable[zaehler] := -1; &END; "END; " "FUNCTION keypress : boolean; " VAR rec : RECORD 0number: integer .END; (par : PACKED ARRAY[0.able[zaehler] := ord(zaehler) - ord('0') *ELSE *IF zaehler IN ['A'..'Z'] THEN * werttable[zaehler] := ord(zaehler) - ord('0') - 7 ,ELSE ,IF zaehler IN ['a'..'z'] THEN .werttable[zaehler] := ord(zaehler) - ord('0') - 13 .ELSE .IF Zaehler = '>' THE$write('Q(uit oder W(eiter ? '); $read(antwort); $IF (antwort = 'Q') OR (antwort = 'q') THEN exit(PROGRAM); "END; " "PROCEDURE tableinit; " VAR &zaehler : char; "BEGIN $FOR zaehler := '0' TO 'z' DO &BEGIN (IF zaehler IN ['0'..'9'] THEN *wertt$esc,steuerzeichen,ch,symm : char; $stpunkt,filename : string; $fertig,sym : boolean;   "PROCEDURE fehler; " VAR &antwort : char; "BEGIN $write(chr(7)); $writeln('Fehler beim Lesen !!'); unkte] OF tzeichen; " "VAR $f : text; $werttable : tablewert; $byte : tbytes; $zeile,zeile2 : tzeile ; $punkte,punkt,anzahl, $wert,farbe,zaehl,artundweise: integer; "CONST $maxpunkte = 1280; " "TYPE $tablewert = ARRAY ['0'..'z'] OF integer; $tbytes = 0..255; $tzeichen = RECORD CASE boolean OF 2true : (bit : PACKED ARRAY[1..8] OF boolean); 2false : (bat : char) /END; " tzeile = PACKED ARRAY[0..maxpise OF .1 : IF (farbe MOD 3 = 0) THEN setzepunkt(zaehl2,zaehl1); .2 : IF odd(farbe) THEN setzepunkt(zaehl2,zaehl1); , 3 : IF farbe = 63 THEN setzepunkt(zaehl2,zaehl1);  4 : IF (farbe > 9) AND (farbe < 63) 6THEN setzepunkt(zaehl2,zaehl1); ,END;  (* Achtung ! Reihenfolge der Parameter beachten ! *)  (* In diese IF-Abfrage lassen sich die verschiedenen *)  (* Modi des Ausdruckens einbauen *)  ,zaehl2 := succ(zaehl2); ,IF zaehl2 = punkt THEN .BEGINck); $wr(chr(13)); wr(chr(10)); $wr(chr(13)); wr(chr(10)); $wr(esc); wr('A'); $wr(esc); wr('N'); $wr(chr(13)); wr(chr(10)); $exit(PROGRAM); "END; "  BEGIN "tableinit; "haeder; "bearbeite; "beende;  END.  aehl := 1 TO 2 DO BEGIN &read(f,zeichen); IF zeichen <> ' ' THEN fehler; " END;  { writeln(punkte:6,anzahl:6,steuerzeichen:6); } " $write('Welche Art des Ausdrucks ? '); $readln(artundweise); $ "END; " "PROCEDURE beende; "BEGIN $close(f,lo*IF punkte <= 960 THEN steuerzeichen := 'q' ,ELSE ,IF punkte <= 1088 THEN steuerzeichen := 'Q' .ELSE .IF punkte <= 1152 THEN steuerzeichen := 'p' 0ELSE 0IF punkte <= 1280 THEN steuerzeichen := 'P'; $ $IF steuerzeichen = '?' THEN fehler; $ $FOR znz); (* links *) $lese(stanz); (* rechts*) " $steuerzeichen := '?'; $IF punkte <= 576 THEN steuerzeichen := 'n' &ELSE &IF punkte <= 640 THEN steuerzeichen := 'N' (ELSE (IF punkte <= 768 THEN steuerzeichen := 'E' *ELSE 2 * punkt -1 &ELSE punkte := punkt; $str(punkte,stpunkt); $stpunkt := concat('000',stpunkt); $stpunkt := copy(stpunkt,length(stpunkt)-3,4);  (* stpunkt wird fuer Ausgabe benoetigt *)  (* sym = true, wenn Symmetrie zur x-Achse vorliegt *) $lese(sta; anzahl := 0; $FOR zaehl := 1 TO length(stanz) DO &anzahl := 10 * anzahl + ord(stanz[zaehl]) - ord('0'); $lese(stpunkt); punkt := 0; $FOR zaehl := 1 TO length(stpunkt) DO &punkt := 10 * punkt + ord(stpunkt[zaehl]) - ord('0'); $IF sym THEN punkte :=  (* jetzt entspricht der Filename der Norm *)  $UNTIL vorhanden (filename); $reset(f,filename); $lese(filename); $read(f,symm); IF symm = 'x' THEN sym := true ELSE sym := false; $read(f,zeichen); IF zeichen <> ' ' THEN fehler; $lese(stanz)ame) DO (IF filename[zaehl] IN ['a'..'z'] THEN *filename[zaehl] := chr(ord(filename[zaehl]) - 32); &IF pos(filename,'.DATA') = 0 THEN (filename := concat(filename,'.DATA'); &IF length(filename) > 15 THEN (delete(filename,10,length(filename) - 15); : string; $BEGIN &s := ' '; &st := ''; &read(f,ch); &WHILE NOT (ch = ' ') DO (BEGIN *s[1] := ch; *st := concat(st,s); *read(f,ch); (END; $END; $ "BEGIN $REPEAT &write('Name des Files > '); &readln(filename); &FOR zaehl := 1 TO length(filen : string; " $FUNCTION vorhanden ( filename : string ) : boolean; $BEGIN &close(f); &(* $I- *) &reset(f,filename); &vorhanden := ioresult = 0; &close(f); &(* $I+ *) $END; $ " PROCEDURE lese (VAR st : string); &VAR (ch : char; (s  (* 15/144" Zeilenvorschub *) $ 4fillchar(zeile2,2*punkte+2,chr(0));  (* die schnellste Methode, das ARRAY zu loeschen *) 4 4zaehl1 := 1; 2END; .END; *END; &END; "END; " $ $ "PROCEDURE haeder; " VAR &zeichen : char; &stanz u loeschen *) 4 4wr(esc);wr('G');wr(stpunkt[1]); 4wr(stpunkt[2]);wr(stpunkt[3]);wr(stpunkt[4]); 4FOR zaehl4 := 1 TO punkte DO 6wr(zeile2[zaehl4].bat); 4 4wr(esc); wr('T'); wr('1'); wr('5'); 4wr(chr(13)); wr(chr(10)); e[zaehl4].bat); 4 4wr(esc); wr('T'); wr('0'); wr('1'); 4wr(chr(13)); wr(chr(10));  (* 1/144" Zeilenvorschub *) $ 4IF keypress THEN exit(PROGRAM);  (* Notbremse *) 4 4fillchar(zeile,2*punkte+2,chr(0));  (* die schnellste Methode, das ARRAY z 0zaehl2 := 0; 0zaehl1 := succ(zaehl1); 0IF zaehl1 = 17 THEN 2BEGIN 4wr(esc);wr('G');wr(stpunkt[1]); 4wr(stpunkt[2]);wr(stpunkt[3]);wr(stpunkt[4]);  (* z.B. ESC G 1280 --> es folgen 1280 Grafik-Zeichen *) 4 4FOR zaehl4 := 1 TO punkte DO 6wr(zeilM ,O^ +16 : Starkschrift fuer verbrauchte Farbbaender   ;-------benutzte page 0 Adressen--------   RETURN .EQU 0  ZEILZ .EQU 02 ; 0..23. zaehlt Druckzeilen  BYTEZ .EQU 03 ; 0..39. zaehlt Bytes pro Zeile  BREIT .EQU 04ert die Art des Ausdrucks :  ; 1 : doppelt breit,  ; 0 : einfach breit  ; dazu:  ; + 2 : doppelt hoch, sonst einfach  ; + 4 : invers, sonst normal  ; + 8 : page 2, sonst page 1  ;  ;oooooooooooooooooooooooooooooooooooooo  (.PROC HARDCOPY,1  ; die '1' sagt, dass 1 Wort uebernommen wird.   ; Deklaration im Host-Programm :  ; PROCEDURE HARDCOPY(PARAMETER : INTEGER); EXTERNAL;  ;  ; Der Parameter steuint- 8; Work-Areas (LDA %1 (STA %2 (LDA %1+1 (STA %2+1 (LDA %1+2 (STA %2+2 (LDA %1+3 (STA %2+3 (LDA %1+4 (STA %2+4 (LDA %1+5 (STA %2+5  .ENDM ( (  ;oooooooooooooooooooooooooooooooooooooo  ;  ; HARDCOPY  ; be (LDA #%1 (STA @DUGL,Y ; uebergibt ein Zeichen (.ENDM ( (.MACRO POP (PLA (STA %1 (PLA (STA %1+1 (.ENDM ( (.MACRO PUSH (LDA %1+1 (PHA (LDA %1 (PHA (.ENDM ( (.MACRO TRANS ; transportiert jeweils 6 Byte 8; zwischen den Floating-Po ausgabe; "BEGIN " readln; $textmode; "END; "  BEGIN  eingabe; "berechne; "ausgabe;  END.   ;-------Assembler-Prozeduren  ;$C M.Doerfler, K.-H. Becker   (.MACRO RAUS  $01 LDA @DFGL,Y (BMI $01 ; wartet auf Freiga&k := links + zaehl1 * (rechts-links)/279.0; &bynr := zaehl1 DIV 7; &maske := 1; &FOR zaehl2 := 1 TO (zaehl1 MOD 7) do (maske := 2 * maske; &p := 0.3; &schleife(k,p,1.0,191.0/(oben-unten),sichtbar,unsichtbar,bynr,maske); $END; "END; " "PROCEDURE readln(oben); $write('unten > '); readln(unten); $write('sichtb.> '); readln(sichtbar); $write('unsichtbar > '); readln(unsichtbar); $initturtle; "END; " "PROCEDURE berechne; "BEGIN $FOR zaehl1 := 0 TO 279 DO BEGIN oben,unten : real; $ "PROCEDURE schleife (k,p,c1,c191 : real; 6sichtbar,unsichtbar,bynr,maske : integer); "EXTERNAL;   PROCEDURE eingabe; "BEGIN $write('links > '); readln(links); $write('rechts > '); readln(rechts); $write('oben > '); den Assembler-text *)  (* Machen Sie bitte 2 Textfiles daraus *)   PROGRAM schneller_Feigenbaum;  "USES $turtlegrafics; $ "VAR $sichtbar,unsichtbar,bynr,maske, $zaehl1,zaehl2 : integer; $k,p,links,rechts, (* Programmbeispiel 3.1 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " (* Enthaelt sowohl den Pascal-text wieauf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30 Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM  HOCH .EQU 05  INVERS .EQU 06  STARK .EQU 07  AUSGABE .EQU 09 ; speichert das auszugebende Byte  ZP0 .EQU 0A ; Zeilenanfangspointer  ZP1 .EQU 0C  ZP2 .EQU 0E  ZP3 .EQU 10  ZP4 .EQU 12  ZP5 .EQU 14  ZP6 .EQU 16  ZP7 .EQU 18  BS0 .EQU 1A ; speichern 8 Byte  BS1 .EQU 1B ; "uebereinander"  BS2 .EQU 1C  BS3 .EQU 1D  BS4 .EQU 1E  BS5 .EQU 1F  BS6 .EQU 20  BS7 .EQU 21  DFGL .EQU 32 oetig  WARTE LDA @DFGL,Y ; Drucker frei ? (BMI WARTE (LDA AUSGABE (BIT INVERS (BPL NORMAL ; normal oder invers ? (EOR #0FF  NORMAL STA @DUGL,Y ; na endlich ! raus damit ! ( (BIT BREIT (BPL SCHMAL (LDA BREIT (EOR #40 (STA BREIT #7  RAUSMIT LSR BS0 (ROR AUSGABE (LSR BS1 (ROR AUSGABE (LSR BS2 (ROR AUSGABE (LSR BS3 (ROR AUSGABE (LSR BS4 (ROR AUSGABE (LSR BS5 (ROR AUSGABE (LSR BS6 (ROR AUSGABE (LSR BS7 (ROR AUSGABE ( (LDY #00 ; fuer indirekte Adressierung n( ; jetzt kommen 280 bzw 560 Grafikzeichen   HOL7B BIT HOCH (BPL EINFACH  DOPPELT BVS MAL2  MAL1 JSR B7OBEN ; beim ersten Durchgang (JMP RAUSM (  MAL2 JSR B7UNTEN (JMP RAUSM   EINFACH JSR B7EINF  (  RAUSM LDXPL KLN (RAUS 35 ; "5" (RAUS 36 ; "6" (BNE GRS  KLN NOP (RAUS 32 ; "2" (RAUS 38 ; "8"  GRS NOP (RAUS 30 ; "0" 8; ESC S 0280 oder ESC S 0560 (bei Breitdruck) X (CPX #10 ; = 16. (BNE HOLADD (  HOL7A LDA #0 (STA BYTEZ ( (LDY #00 ; fuer indirekte Adressierung (RAUS 1B ; "ESC" (RAUS 53 ; "S" (RAUS 30 ; "0" (BIT BREIT ; testet Bit 7 : gross oder klein ? (Bte Zeile------------------   LDA #0 (STA ZEILZ  NEUZLE LDA ZEILZ (ASL A (ASL A (ASL A (TAY  LDX #00   ;-------Adressen der Zeilenanfaenge-----   HOLADD LDA ZEILLO,Y (STA ZP0,X (INX (LDA ZEILHI,Y (STA ZP0,X (INY (IN(RAUS 3E ; '>' unidirektionaler Druck ( (RAUS 1B ; 'ESC' (RAUS 6E ; 'n' 72 dots/inch; 576 dots/line ( ; (gleicher Punktabstand horizontal & vertikal)  RAUS 0D (RAUS 0A   ;-------naechs'Z' (RAUS 00 ; '0' (RAUS 20 ; '32' : ESC Z 0 32 -->'8 Bit-Daten' ( (RAUS 1B ; 'ESC' (RAUS 54 ; 'T' (RAUS 31 ; '1' (RAUS 36 ; '6' : ESC T 16 --> 16/144 = 1/9 " Linefeed ( (RAUS 1B ; 'ESC' A DFGH (STA DFGL ; C1C1 (   ;-------Drucker initiieren-------------- ( (RAUS 00 ; '0' ( (BIT STARK (BPL NIST (RAUS 1B ; 'ESC' (RAUS 21 ; Starkschrift (  NIST NOP (RAUS 1B ; 'ESC' (RAUS 5A ; OR STARK   HOLMSB LDY #00 ; fuer indirekte Adressierung (PLA ; MSB des Parameters wird verworfen   ;-------Druckeradressen ----------------  (LDA #90 (STA DUGL (LDA #0C0 (STA DUGH ; C090 (LDA #0C1 (ST(STA INVERS (STA STARK ( (PLA (ROR A (ROR BREIT (ROR A (ROR HOCH (ROR A (ROR INVERS ( (ROR A (BCC SEITE1 ; p steht noch im CARRY (PHA (JSR MAKEP2 ; dort werden Startadressen veraendert  PLA  SEITE1 ROR A (BCC HOLMSB (Rt ist, wird Bit 7 gesetzt.  ; In Bit 6 wird ggf. der erste bzw. zweite Duchlauf  ; festgehalten.  ; Falls Seite 2 gewuenscht ist, wird in einem Unterprogramm  ; die Liste der Zeilenanfangsadressen geaendert.  (LDA #0 (STA BREIT (STA HOCH ------------------------ (POP RETURN ; return-adresse wird in 00 und 01 aufbewahrt   ;-------Parameteruebergabe-------------- (  ; Es werden vier Flags angelegt, fuer Breit, Hoch, Invers und  ; fuer Starkschrift..  ; Falls die Option gewuensch ; LSB Druckerfreigabe-adresse  DFGH .EQU 33 ; MSB Druckerfreigabe-adresse  DUGL .EQU 34 ; LSB Druckeruebergabe-adresse  DUGH .EQU 35 ; MSB Druckeruebergabe-adresse   .REF ZEILHI,ZEILLO (  ;---------------(BIT BREIT (BVS WARTE ( (  SCHMAL DEX (BNE RAUSMIT ( (INC BYTEZ (LDA BYTEZ (CMP #28 ; = 40. (BNE HOL7B ( (RAUS 0D ; 'CR' (RAUS 0A ; 'LF' ( (LDA HOCH (EOR #40 (STA HOCH (BIT HOCH (BPL WEITERZ ; wenn Bit 7 = 0 (BVC WEITERZ (JMP HOL7A (  WEITERZ INC ZEILZ (LDA ZEILZ (CMP #18 ; = 24. (BNE NEU ( (JMP ABSCHL (  NEU JMP NEUZLE ( (   ;-------Abschalten---------------------- ( (  ABSCHL LDY #00 (RAUS 1SKE ; Kopiermaske ( (TYA (TAX ; = TYX ( (LDA MERKS (AND LMAS (PHA ( (INY  LDA @AADR,Y (STA MERKER (  SCHIEB LSR MERKER ; das naechste Byte entsprechend oft (ROR MASKE ; in die Maske hineinschieben (DEX BY LDY #00 ; aus 8 Byte auf der Grafikseite 8; werden 7 Byte im array DRAWFLD  ; Y ist der Zaehler (LDA @AADR,Y (STA MERKS ( (LDA #7F ; = 0111 1111 (STA LMAS ; Loeschmaske   NEXTBYT LDA #00 (STA MA(LDA ZEILLO,Y ; aus den Pointertabellen (STA AADR ; wird die Adresse des ersten (LDA ZEILHI,Y ; Bytes der Zeile geholt (STA AADR+1 ( (LDA #05 ; jede Zeile auf der Grafikseite (STA BIS5Z ; besteht aus 5*8 = 40. Byte (  ABY7 (PUSH RETURN (RTS ; zurueck nach PASCAL ( (  ;----------------------------------------  ; Subroutines (hier nur eine)  ;----------------------------------------   ZEILE LDY ZEILZ ; arbeitet eine Zeile ab 8   ;------- Hauptprogramm -----------------   ANFANG POP RETURN (POP DRAWFLD  (LDA #00 (STA ZEILZ (  START JSR ZEILE (INC ZEILZ ; herunterzaehlen (LDA ZEILZ (CMP #0C0 ; = 192. (BNE START ; schon bei Null ? ( LMAS .EQU BASIS+8  MASKE .EQU BASIS+10. ; Dezimalzahl  AADR .EQU BASIS+12.  MERKER .EQU BASIS+14.  MERKS .EQU BASIS+15.  ZEILZ .EQU BASIS+10 ; BEACHTE : keine Dezimal- sondern Hexzahl  BIS5Z .EQU BASIS+11  (.REF ZEILHI,ZEILLO  ; bitmuster = PACKED ARRAY[0..279,0..191] OF boolean;  ;  ; PROCEDURE invdraw(VAR drawfeld : bitmuster);  ; External;  ;  ;------- page 0-Adressen ---------------   BASIS .EQU 0  RETURN .EQU BASIS  DRAWFLD .EQU BASIS+6 oooooooooooooo  ;  ; INVERSER DRAWBLOCK  ;  ;oooooooooooooooooooooooooooooooooooooo  ( (.PROC INVDRAW,1  ;  ; Aufruf im PASCAL-Hauptprogramm :  ; TYPE  ; byte = 0..255; BS3 (LDA @ZP6,Y (STA BS4 (STA BS5 (LDA @ZP7,Y (STA BS6 (STA BS7  RTS   MAKEP2 LDY #0C0 ; veraendert Zeilenanfangsadressen  LOOP DEY (LDA ZEILHI,Y (CLC (ADC #20 (STA ZEILHI,Y (BNE LOOP (RTS   ;oooooooooooooooooooooooo(STA BS3 (LDA @ZP2,Y (STA BS4 (STA BS5 (LDA @ZP3,Y (STA BS6 (STA BS7  RTS (  B7UNTEN LDY BYTEZ ; laedt die unteren 8 Bit einer (LDA @ZP4,Y ; einfachen Druckzeile jeweils doppelt (STA BS0 (STA BS1 (LDA @ZP5,Y (STA BS2 (STA(LDA @ZP4,Y (STA BS4 (LDA @ZP5,Y (STA BS5 (LDA @ZP6,Y (STA BS6 (LDA @ZP7,Y (STA BS7  RTS (  B7OBEN LDY BYTEZ ; laedt die oberen 8 Bit einer (LDA @ZP0,Y ; Druckzeile jeweils doppelt (STA BS0 (STA BS1 (LDA @ZP1,Y (STA BS2 urueck nach PASCAL (  ;-------Unterprogramme------------------   B7EINF LDY BYTEZ ; laedt die uebereinanderstehenden (LDA @ZP0,Y ; 8 Byte auf Seite 0 (STA BS0 (LDA @ZP1,Y (STA BS1 (LDA @ZP2,Y (STA BS2 (LDA @ZP3,Y (STA BS3 (RAUS 45 ; 'E' --> Elite-Schrift 96 dpi (RAUS 1B ; 'ESC' (RAUS 44 ; 'D' (RAUS 00 ; = 0 (RAUS 20 ; = 32 --> 7-Bit-Daten (RAUS 0D ; 'CR' (RAUS 0A ; 'LF' ( (PUSH RETURN (RTS ; zB ; 'ESC' (RAUS 22 ; '"' --> Abschalten Starkschrift (RAUS 1B ; 'ESC' (RAUS 41 ; 'A' --> 1/6 " Zeilenvorschub (RAUS 1B ; 'ESC' (RAUS 3C ; '<' --> Bidirektionaler Druck (RAUS 1B ; 'ESC' (BPL SCHIEB ( (LDA MERKER (STA MERKS ( (PLA (ORA MASKE ; hineinkopieren (DEY (STA @DRAWFLD,Y ( (LSR LMAS ; Loeschmaske aendern ( (INY (CPY #07 (BCC NEXTBYT ( (LDA AADR ; Adresse auf der Grafikseite (CLC ; um 8 erhoehen (ADC #08 (STA AADR (LDA AADR+1 (ADC #00 (STA AADR+1  (LDA DRAWFLD ; Zieladresse um 7 erheohen (CLC (ADC #07 (STA DRAWFLD (LDA DRAWFLD+1 (ADC #00 (STA DRAWFLD+1 ( (DEC BIS5Z (BNE ABY7BY ( (RTS (   ( (LDA #0C0 ; 192 (SEC ; y-Koordinate := 192 - y-Koo, (SBC 77 ; sonst steht das Bild auf (TAY ; dem Kopf ( (LDA ZEILLO,Y (STA ZEILE (LDA ZEILHI,Y (STA ZEILE+1 ( (LDY BYTENANS K,FPWA2 ( (JSR FPMULT ( (TRANS FPWA3,FPWA1 ( (TRANS FPWA3,P ; k * p * (1-p) ( (TRANS C191,FPWA2 ; 191.0 ( (JSR FPMULT ( (TRANS FPWA3,FPWA1 ; 191*k*p*(1-p) (LDA #01 (STA 86 ; d.h. round (JSR FPROUND JSCHR JMP SCHRITT ; statt branch (too long)   ;-------Schleife mit Zeichnen-----------   ZSCHRIT TRANS P,FPWA1 (  TRANS C1,FPWA2 ( (JSR FPSUB ( (TRANS P,FPWA1 ( (TRANS FPWA3,FPWA2 ( (JSR FPMULT ( (TRANS FPWA3,FPWA1 ( (TR ; p * (1-p) ( (TRANS K,FPWA2 ; k ( (JSR FPMULT ( (TRANS FPWA3,FPWA1 ; k * p * (1-p) ( (TRANS FPWA3,P ( (DEC UNSICH (BNE JSCHR ( (DEC UNSICH+1 (BPL JSCHR ( (JMP ZSCHRIT ; weiter geht's ( (  ;-------Schleife ohne Zeichnen---------- ( (TRANS P,FPWA1 ; p (  SCHRITT TRANS C1,FPWA2 ; 1.0 ( (JSR FPSUB ( (TRANS FPWA3,FPWA2 ; 1.0 - p ( (TRANS P,FPWA1 ; .. leider.. ( (JSR FPMULT ( (TRANS FPWA3,FPWA1 (.REF ZEILHI,ZEILLO 8  ;-------Hauptprogramm-------------------   START POP RETURN  (POP MASKE (POP BYTENR (POP UNSICH (POP SICHTB ( (LDX #C191 (JSR FPPOP ( (LDX #C1 (JSR FPPOP ( (LDX #P (JSR FPPOP ( (LDX #K (JSR FPPOP  FPVGT .EQU 0EA72 ; vergleicht und tauscht ggf.   FPMULT .EQU 0EBE6 ; FPWA3 := FPWA1 * FPWA2   FPROUND .EQU 0ED6D ; ein : in 86 0 -> TRUNC, 1 -> ROUND, 8; in FPWA1 real-Zahl 8; aus : integer-Zahl, in 76 MSB, in 77 LSB (!)  FPWA3 8; Achtung : FPWA1 wird ueberschrieben !   FPSUB .EQU 0EA39 ; FP-Subtraktion  ; ein : 2 positive Werte, groesserer 8; in FPWA2  ; Achtung : FPWA1 wird ueberschrieben !  e erste Zahl auf dem Stack 8; (TOS) wird "unpacked" dort abgelegt  FPPUSH .EQU 0E257 ; FP-push   FPADD .EQU 0EA13 ; FP-Addition  ; ein : 2 positive Werte in FPWA1 & 2  ; aus : Summe in; der p-Code-Interpreter   ;-------p-Code-Interpreter-Routinen-----  ; Anm.:  ; Dies sind echte Unterprogramme.  ; Alle Zahlen muessen > 0 sein !    FPPOP .EQU 0E929 ; FP-pop : in X wird Anfangsadresse 8; uebergeben, di P .EQU BASE+12 ; Population   ;-------Zwischenspeicher fuer Zahlen, System   FPWA1 .EQU 74 ; Floating-Point-Work-Area  FPWA2 .EQU 7A ; Arbeitsbereich f}r real-  FPWA3 .EQU 80 ; Operationen, damit arbeitet 8  BYTENR .EQU BASE+6  MASKE .EQU BASE+8  ZEILE .EQU BASE+0A    ;-------Zwischenspeicher fuer Zahlen, eigene   C1 .EQU BASE+1E ; konst = 1.0  C191 .EQU BASE+24 ; konst = 191.0  K .EQU BASE+18 ; Kopplungskonstante sichtbar,unsichtbar,bytenr,maske : integer);  ;  ; Aufruf :  ; schleife(k,p,1.0,191.0,sichtbar,unsichtb,bnr,maske);  ;---------------------------------------  BASE .EQU 00  RETURN .EQU BASE  UNSICH .EQU BASE+2  SICHTB .EQU BASE+4 ;oooooooooooooooooooooooooooooooooooooo  ;  ; FEIGENBAUM-ASSEMBLER  ;  ;oooooooooooooooooooooooooooooooooooooo  ( (.PROC SCHLEIFE,12.  ;  ; Vereinbarung:  ; PROCEDURE schleife(k,p,c1,c191 : real;  ; R ( (LDA @ZEILE,Y (ORA MASKE (STA @ZEILE,Y ( (DEC SICHTB (BNE JZSCH ( (DEC SICHTB+1 (BPL JZSCH ( (JMP ZRCK   JZSCH JMP ZSCHRIT (  ;-------fertig--------------------------   ZRCK PUSH RETURN (  RTS ; zurueck nach Pascal ( (  ;--------------------------------------- (.PROC ZEILEN ( (.DEF ZEILHI,ZEILLO (;das ist die einzge Aufgabe der (;Prozedur. ( (RTS ( (  ;-------Zeilenanfangsadressen-----------   ZEIL a HiRes Screen * #* Dump to a DOS - Bfile, which will be loaded into the first HiRes * #* page. * #* * #****************** *)   {$I-}   program FotoToDos;  "{********************************************************************* #* * #* This program copies a UCSD - fotofile containing    (* Programmbeispiel 3.2 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *)  (* von Frank Schomburg, Bremen auf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30 Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM X S !%O^,0D0 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 20,0  + (.END  ,80 (.BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 8,50 (.BLOCK 8(.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D (.BYTE 22, 26, 2A, 2E, 32, 36, 3A, 3E (.BYTE 22, 26, 2A, 2E, 32, 36, 3A, 3E (.BYTE 23, 27, 2B, 2F, 33, 37, 3B, 3F (.BYTE 23, 27, 2B, 2F, 33, 37, 3B, 3F  ZEILLO .BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,0 (.BLOCK 8A, 3E (.BYTE 22, 26, 2A, 2E, 32, 36, 3A, 3E (.BYTE 23, 27, 2B, 2F, 33, 37, 3B, 3F (.BYTE 23, 27, 2B, 2F, 33, 37, 3B, 3F (.BYTE 20, 24, 28, 2C, 30, 34, 38, 3C (.BYTE 20, 24, 28, 2C, 30, 34, 38, 3C (.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D 2B, 2F, 33, 37, 3B, 3F (.BYTE 23, 27, 2B, 2F, 33, 37, 3B, 3F (.BYTE 20, 24, 28, 2C, 30, 34, 38, 3C (.BYTE 20, 24, 28, 2C, 30, 34, 38, 3C (.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D (.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D (.BYTE 22, 26, 2A, 2E, 32, 36, 3HI .BYTE 20, 24, 28, 2C, 30, 34, 38, 3C (.BYTE 20, 24, 28, 2C, 30, 34, 38, 3C (.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D (.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D (.BYTE 22, 26, 2A, 2E, 32, 36, 3A, 3E (.BYTE 22, 26, 2A, 2E, 32, 36, 3A, 3E (.BYTE 23, 27,***************************************************}   type Byte = 0..255;   Alpha = string[8]; % %SectorType = packed array [0..255] of Byte; % %BlockType = array [0..1] of SectorType; %  var VTOC : SectorType; {volume table of contents} $TrackSector : SectorType; {track-sector list} $TSLTrk, TSLSec : integer; {position of TrackSector} $Directory : SectorType; {directory} $DirTrk, DIrSec : integer; {pelse (if Free then *Bool:= false (else *begin ,{$R-} ,moveleft (Directory[Start+3], FileName[1], 30); ,FileName[0]:= chr(30 + scan(-30, <>chr(160), FileName[30])); ,{$R+} ,for I:=1 to length (FileName) do .FileName[I]:=chr (ord (FileName[I]) mod d (DirTrk=0) then *exit (FindEntry) (else *ReadSector (DirTrk, DirSec, Directory); &Start:= 11 + 35 * Entry; &if Directory[Start]=0 then (if not Free then *exit (FindEntry); &if (Directory[Start]=255) OR (Directory[Start]=0) then & Bool:= Free &&Entry : integer; &FileName: string; &I : integer; "begin $SetDirStart; $Entry:= 0; $FindEntry:= false; $repeat &if Entry=7 then (begin *Entry:=0; *DirTrk:=Directory[1]; *DirSec:=Directory[2] (end; &if Entry=0 then (if (DirSec=0) an); $if VTOC[3]<>3 then &Error ('Disk isn''t DOS') "end; {LoadVTOC} "procedure SetDirStart; "begin $DirTrk:= VTOC[1]; $DirSec:= VTOC[2] "end; {SetDirStart} " "function FindEntry (Free: boolean): boolean; "var Bool : boolean; '); $case Slot of &4 : Device:=Slot+Drive+4; &5 : Device:=Slot+Drive+5; &6 : Device:=Slot+Drive-3 $end; $unitclear (Device); $if ioresult<>0 then &Error ('Device not present') "end; {GetName} "procedure LoadVTOC; "begin $ReadSector (17,0, VTOCile)=0 then $ Error (''); $Slot:=6; $Drive:=1; $Leng:= length (BasicFile); $if Found then &begin (Leng:=Leng-3; (if Found then &end; $if not (Slot IN [4..6]) then &Error ('Illegal slot'); $if not (Drive IN [1..2]) then &Error ('Illegale drive0Error ('Illegal format'); ,delete (BasicFile, Leng-2, 3) *end (else *Found:=false $end; {Found}  "begin {GetName} $write ('Put Dos3.3-Disk into #4:'); $writeln; $write ('Write as what basic file -> '); $readln (BasicFile); $if length (BasicFegin &if Leng>=3 then (if BasicFile[Leng-2] = ',' then *begin ,Found:=true; ,if BasicFile[Leng-1] = 'D' then .Drive:= ord(BasicFile[Leng]) - ord('0') ,else .if BasicFile[Leng-1] = 'S' then 0Slot:= ord(BasicFile[Leng]) - ord('0') .else $Block [Sec mod 2]:= Sector; $unitwrite (Device, Block, 512, BlockNum); $if ioresult<>0 then &Error ('Write error') "end; {WriteSector} " "procedure GetName; "var Leng : integer; &Drive: integer; &Slot : integer;  $function Found: boolean; $bByte; var Sector: SectorType); "var BlockNum: integer; &Block : BlockType; "begin $if (Sec<>0) and (Sec<>15) then &Sec:=15-Sec; $BlockNum:= Trk*8 + Sec Div 2; $unitread (Device, Block, 512, BlockNum); $if ioresult<>0 then &Error ('Read error'); $if (Sec<>0) and (Sec<>15) then &Sec:=15-Sec; $BlockNum:= Trk*8 + Sec Div 2; $unitread (Device, Block, 512, BlockNum); $if ioresult<>0 then &Error ('Read error'); $Sector:= Block [Sec mod 2] "end; {ReadSector} " "procedure WriteSector (Trk, Sec: ln (chr(12), 'Program to copy PASCAL Foto-files to DOS Bfiles'); " FreeTrk:=18; $FreeSec:=15 "end; {Init} " "procedure ReadSector (Trk, Sec: Byte; var Sector: SectorType); "var BlockNum: integer; &Block : BlockType; "begin Sector : SectorType; {sector for output} $FreeTrk, FreeSec: integer; {last unused sector found} $ "procedure Error (s: string); "begin $writeln; $writeln (chr(29),s); $exit (program) "end; {Error} "procedure Init; "begin $writeosition of Directory} $Start : integer; {start of file-entry in Directory} $BasicFile : string; {name of BASIC - ouputfile} $FotoFile : file; {input textfile} $Device : integer; {device of output}  128); ,Bool := (BasicFile = FileName) *end; &Entry:= Entry+1 " until Bool; $FindEntry:= true "end; {FindEntry}  "procedure Release (Trk, Sec: integer); "var s: integer; " t: integer; &x: record +case boolean of -true : (IntValue: integer); -false: (BitField: packed array [0..15] of boolean) )end; "begin $t:= 56 + 4*Trk + (1 - Sec Div 8); $s:= Sec mod 8; $x.IntValue:= VTOC[t]; $if x.BitField[s] then &Error ('Error in VTOC') $else &x.BitField[s]:=true; oto-file'); " UCSD.Start:= 8192; (UCSD.Leng:= 8192; (for i:= 1 to 33 do *WriteSector (TrackSector[10+2*i], TrackSector[11+2*i], DOS[i]) &end "end; {Convert} ( "procedure WriteDirectory; "begin " TrackSector[1]:=0; $TrackSector[2]:=0; $Wrinteger; < Leng : integer; BData1: array [1..16] of BlockType @end); " false:(DOS : array [1..33] of SectorType) /end; "begin $with Picture do &begin (if blockread (FotoFile, UCSD.Data1, 16) <> 16 then *Error ('Read error in f$for I:= length(BasicFile)+1 to 30 do &Directory[Start+2+I]:= 160; $Directory[Start+33]:=34; $Directory[Start+34]:=0 "end; {OpenTrackSector} " "procedure Convert; "var i: integer; &Picture: record 1case boolean of 3true: (UCSD: record BStart: i0+2*i]:=FreeTrk; (TrackSector[11+2*i]:=FreeSec &end; $Directory[Start] := TSLTrk; $Directory[Start+1]:=TSLSec; $Directory[Start+2]:=132; $for I:=1 to length(BasicFile) do &Directory[Start+2+I]:= ord (BasicFile[I]) + 128; ile not Found') "end; {OpenInput} "  procedure OpenTrackSector; "var I: integer; "begin $Request; $TSLTrk:= FreeTrk; $TSLSec:= FreeSec; $fillchar (TrackSector, SIZEOF(TrackSector), chr(0)); $for i:=1 to 33 do &begin (Request; (TrackSector[1'); $readln (Name); $writeln; $if length (Name) = 0 then &Error (''); $p:= pos ('.',Name); $if p = length(Name) then &delete (Name, p, 1); $if p = 0 then &Name:= concat (Name, '.FOTO'); $reset (FotoFile, Name); $if ioresult <> 0 then &Error ('F,ReleaseSector (end &else (begin *if not FindEntry (true) then ,Error ('No room in directory'); *OK:= true (end $until OK "end; {GetEntry}   procedure OpenInput; "var Name: string; " p : integer; "begin $write ('Name of fotofile -> tor}  "procedure GetEntry; "var Ch: char; " OK: boolean; "begin $repeat &GetName; &LoadVTOC; &if FindEntry (false) then (begin *write ('File exists, replace it (y/n) ?'); *read (Ch); *writeln; *OK:= (Ch='Y') OR (Ch='y'); *if OK then t AllReleased then (Release (Trk, Sec); &if I mod 122 = 0 then (begin *TSLTrk:= TrackSector [1]; *TSLSec:= TrackSector [2]; *Release (TSLTrk, TSLSec); *ReadSector (TSLTrk, TSLSec, TrackSector) (end; &I:=I+1 " until AllReleased "end; {ReleaseSecy [Start+1]; $Release (TSLTrk, TSLSec); $I:=1; $repeat &if I mod 122 = 1 then (ReadSector (TSLTrk, TSLSec, TrackSector); &Trk:= TrackSector[2*((I-1) mod 122)+12]; &Sec:= TrackSector[2*((I-1) mod 122)+13]; &AllReleased:= (Trk=0) and (Sec=0); &if no(else *Error ('Not enough room on volume') $until false "end; {Request} " "procedure ReleaseSector; "var AllReleased: boolean; " I : integer; " Trk, &Sec : integer; "begin " TSLTrk:= Directory [Start]; $TSLSec:= Directoreat &repeat (if Free (FreeTrk, FreeSec) then *exit (Request); (FreeSec:=FreeSec-1 &until FreeSec<0; &FreeSec:=15; &if FreeTrk>17 then (if FreeTrk<34 then *FreeTrk:=FreeTrk+1 (else *FreeTrk:=16 &else (if FreeTrk>3 then *FreeTrk:=FreeTrk-1 56 + 4*Trk + (1 - Sec Div 8); $s:= Sec mod 8; $x.IntValue:= VTOC[t]; $if not x.BitField[s] then &Free:= false $else &begin & x.BitField[s]:=false; (Free:= true; (VTOC[t]:=x.IntValue " end "end; {Free} " "procedure Request; "begin " rep$VTOC[t]:=x.IntValue "end; {Release} " "function Free (Trk, Sec: integer): boolean; "var s: integer; " t: integer; &x: record +case boolean of -true : (IntValue: integer); -false: (BitField: packed array [0..15] of boolean) )end; "begin $t:=teSector (TSLTrk, TSLSec, TrackSector); $WriteSector (DirTrk, DirSec, Directory); $WriteSector (17, 0 , VTOC) "end; {WriteDirectory} " "procedure Finish; "begin $gotoxy(0,20); $Write('Put in UCSD-System-Disk '); $Readln; "end; {Finish} "  begin {main} "Init; "OpenInput; "GetEntry;  OpenTrackSector; "Convert; "WriteDirectory;  Finish;  end. {pastobas}   m Invertieren der Grafikseite 1 1470 *-------------------------------------------- 1480 * 1490 * 1500 INVERT LDA #$0 1510 STA TEMP 1520 LDA #$20 1530 STA TEMP+1 1540 INV1 LDY #$0 1550 INV2 LDA (TEMP),Y 1560 EOR #$7F 1570 se 1390 BLOCK .HS FF00 Blocknummer 1400 NUMBER .HS FF Blockanzahl 1410 ERRFLG .HS 00 Flag fur Lesefehler 1420 *-------------------------------------------- 1430 * 1440 * 1450 *-------------------------------------------- 1460 * Programm zu1310 .DA PARAM Zeiger auf Parameterliste 1320 STA ERRFLG 1330 RTS 1340 * 1350 *-------------------------------------------- 1360 PARAM .HS 03 Parameteranzahl 1370 UNIT .HS E0 S6,D2 1380 BUFFER .HS 00FF Pufferadres1220 INC BLOCK 1230 BNE SKIP 1240 INC BLOCK+1 1250 SKIP DEX 1260 BNE LOOP 1270 END RTS 1280 *-------------------------------------------- 1290 READ JSR MLI 1300 .HS 80 READ-Parameter loecken 1100 * unter ProDos 1110 *-------------------------------------------- 1120 * 1130 * 1140 MLI .EQ $BF00 1150 TEMP .EQ $CE 1160 * 1170 START LDX NUMBER 1180 LOOP JSR READ 1190 BNE END 1200 INC BUFFER+1 1210 INC BUFFER+1 ----------------- 1010 * PASCAL --> PRODOS 1020 * Volkmar Ahrens 27.8.85 1030 *-------------------------------------------- 1040 * 1050 .OR $4800 1060 * 1070 * 1080 *-------------------------------------------- 1090 * Programm zum Lesen von B   (* Programmbeispiel 3.x3aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) 1000 *---------------------------auf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30 Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM O^ STA (TEMP),Y 1580 DEY 1590 BNE INV2 1600 INC TEMP+1 1610 LDA TEMP+1 1620 CMP #$40 1630 BNE INV1 1640 RTS 1650 * 1660 *-------------------------------------------- 1000 HOME 1010 PRINT "BILDTRANSFER UCSD --> PRODOS" 1020 PRINT 1030 PRINT "ProDos-Diskette in S6,D1" 1040 PRINT "Pascal-Diskette in S6,D2" 1050 PRINT 1054 REM *************************************** 1055 REM *** Einlesen des Maschinenprogramms *** 1056 REM *TAB 2 1680 FOR K = 0 TO N 1690 IF K = P THEN PRINT " > ";: INVERSE : PRINT NA$(K): NORMAL : GOTO 1710 1700 PRINT " " + NA$(K) 1710 NEXT K 1720 RETURN 1724 REM ************************* 1725 REM *** Maschinenprogramm *** 1726 REM ****************REM ****************************************** 1640 TEXT 1650 PRINT CHR$ (7): HOME 1660 GOTO 1630 1664 REM ************************************** 1665 REM *** Ausgabe Liste aller Foto-Files *** 1666 REM ************************************** 1670 V1596 REM ***************************************** 1600 HOME 1610 PRINT CHR$ (4);"BSAVE";NA$(W);",A$2000,L$2000" 1620 TEXT 1630 GOTO 1200 1634 REM ****************************************** 1635 REM *** Meldung und Abbruch bei Lesefehler *** 1636 560 POKE NO,16 :REM File-Laenge 8K 1570 CALL M 1580 IF PEEK (ER) THEN 1640 : REM Lesefehler 1590 CALL IN : REM Invertierung des Bildes 1594 REM ***************************************** 1595 REM *** Schreiben des Bildes unter ProDos *** *************** 1525 REM *** Einlesen des Foto-Files *** 1526 REM ******************************* 1530 HGR 1540 POKE BU,32 : REM Puffer ist Grafikseite 1 1550 POKE BL,B(W) - 256 * INT(B(W) / 256) : REM Erster Block 1555 POKE BL + 1, INT(B(W) / 256) 1CHR$ (21) OR X$ = CHR$(32) THEN P = P + 1: IF P > N THEN P = 0 1470 IF X$ = CHR$ (8) THEN P = P - 1: IF P < 0 THEN P = N 1490 IF X$ = "Q" THEN HOME : END 1500 IF X$ <> CHR$ (13) THEN 1430 1510 W = P 1520 IF P = 0 THEN 1230 1524 REM ****************1400 NEXT I 1404 REM ******************************** 1405 REM *** Auswahl eines Foto-Files *** 1406 REM ******************************** 1410 VTAB 22 1420 PRINT "<- , -> , RETURN oder Q" 1430 GOSUB 1670 1440 VTAB P + 2 1450 GET X$ 1460 IF X$ = L = 0 THEN 1400 1340 N = N + 1 1350 B(N) = PEEK (I) + 256 * PEEK (I + 1) : REM Erster Block des Files 1360 NA$(N) = "" : REM Extrahieren des File-Namens 1370 FOR J = 1 TO L 1380 NA$(N) = NA$(N) + CHR$ ( PEEK (I + 6 + J)) 1390 NEXT J *** 1285 REM *** Analyse der Directory *** 1286 REM ***************************** 1290 N = 0 1300 FOR I = DI TO DI + 2047 STEP 26 1310 IF PEEK (I + 4) < > 7 THEN 1400 : REM kein Foto-File 1320 L = PEEK (I + 6) : REM Laenge des File-Namens 1330 IFHOME 1240 POKE BU,64 : REM Puffer ab $4000 1250 POKE BL,2 : REM Directory beginnt mit Block 2 1255 POKE BL + 1, 0 1260 POKE NO,4 : REM Laenge der Directory 1270 CALL M 1280 IF PEEK (ER) THEN 1640 : REM Lesefehler 1284 REM **************************1200 VTAB 22: PRINT "RETURN oder Q ";: GET X$: PRINT 1210 IF X$ = "Q" THEN HOME : END 1220 IF X$ < > CHR$ (13) THEN 1200 1224 REM ****************************** 1225 REM *** Einlesen der Directory *** 1226 REM ****************************** 1230 ******** 1170 DIM NA$(17) 1180 NA$(0) = "ANDERE DISKETTE" 1190 DIM B(17) 1194 REM ******************************** 1195 REM *** Start des Hauptprogramms *** 1196 REM ******************************** ************************************** 1100 M = 18432 1110 BU = 18471 1120 BL = 18472 1130 NO = 18474 1140 ER = 18475 1150 IN = 18476 1160 DI = 16384 1164 REM ************************* 1165 REM *** Initialisierungen *** 1166 REM ******************************************************* 1060 FOR I = 18432 TO 18503 1070 READ X 1080 POKE I,X 1090 NEXT I 1094 REM *************************************************** 1095 REM *** Adressen zum Patchen des Maschinenprogramms *** 1096 REM ********************** 1730 DATA 174,42,72,32,26,72,208,17,238,39 1740 DATA 72,238,39,72,238,40,72,208,3,238 1750 DATA 41,72,202,208,234,96,32,0,191,128 1760 DATA 36,72,141,43,72,96,3,224,0,255 1770 DATA 225,0,255,0,169,0,133,206,169,32 1780 DATA 133,207,160,0,177,206,73,127,145,206 1790 DATA 136,208,247,230,207,165,207,201,64,208 1800 DATA 237,96 L]~@A ] lY<-xp?Bs?n}cBE_VLCx|@x~`ct__4l|d x|Ij8x - y?V|`}1A-jLqom`Upxvy|p|pz8%|ydj?n||`` >.`}u`SDD|p?`?p>q|?p?Xx8",:Rpgla|L|c@3&R~ApVEg?p` v~pSfhY:^/13~?"+hq>~&+I@Ce|`HCc|?x1x|k~ ~Y*0bxp~x37p0n@<G%v@aH(c`03x@p`N`:xlp@?xxp|Ac,@~~@d8|3`x?`) `W96[~Lyac2x vfq@@|x;%@"J@'x|`~@~@xsX@x0TJ?g0 fx?|;qZODp' 7"~?DZro@!x#Ja||d '.PHOTO'werden nacheinander gezeigt./Bitte die Verzoegerung eingeben, dabei bedeutetצ2'0', dass der Bildwechsel auf Tastendruck erfolgt.צ Ende mit  ----->  )ҥ 601%@Fr *** SLIDESHOW ***צ'Alle Files vom Typ '.FOTO' und '.PHOTO'werden nacheinander gezeigt./Bitte die Verzoegerung eingeben, dabei bedeutetצ2'0', dass der Bildwechsel auf Tastendruck erfolgt.צ Ende mit ")P á  ȡ  QqÍQqÍ|~G  *** SLIDESHOW ***צ'Alle Files vom Typ '.FOTO' unlV تP.FOTOˡ3 ҩh.PHOTOˡTҥá$## Rá ; Q˄q˄] 744N ȡd 4N Pצ.PHOTO צ.FOTO ō)7")צ#5: SP44N ȡd 4N P.PHOTOץ Ŧ.FOTOץ ō)7")#4: SPBpSLIDESHO @7`ijECSl3sn W |?2J#x?`-xf-x'@SA|p~p@@xyq\>&h|`@~@/|pfz@C%+I|{:* (E?`}Yodx``'l1}Gx0HdA?p|`?~p<6 |?xY veC`p@`p`N);pGP|p?lx@pppqgi @BsOfypEsx@S/8|s++ |@@ :~u@?{Kbp~||A!@YL`S,xxpC~@~@ B~*!K ok"f|`Sf|\\t@&y" x@xQfEA|oHcx|o`@Kpc1&M`< ~~8|e`30p?xREx|]:spxx~Cj|%Xfdx@~`?.y^T~Ld/ @`r\X !|'`|CI}8tOj8x`@?`?`'~7X:lRt@4,IGqA`xKD||aiz.jQ8Z9x@]7zx~?xpNq\8q xx|`gYtx2  $p 7${6Ao}pTpso0M6xG/B(s`?|?A`3rdq `X5p%=Ph(r'q_6p#jA@Op3j&Y-x~| 7$0K9x"x`,~0x|;cy~k6lex)C|?JeO,cAxT=x#8" pL F9@x|@"pE'`c96 D*hpRQ7p=-s`xC`GYnq|}y c|\NQB{J2C?'@|Cm~9p|,@19hvp|@??XE;l* +3C/&~@ =Gqlx@GiuB /wL1xap~~@L~WOLExZq@*JcqA@@@sp EgHeFS[yp`=v~x|?p`Nqy,xp?@?`GY(L@E?" ?~~sw?|r{* t{3t  qr`~?`5y?iL|Q4pp~`~>`%T"`@ 9 ce?|'qM~FU&Ta~HbKM9p?2~,>x~ay;?  8K%|*Gl|S2G~x(sx]&Gp< @G3jpTl 9@%0f8Zy'aJ~<.|3Phx`p~#H9-R xPh30N/x`?xp`1uzpl%@Yf~Gh~X p@&cE~R" s@A||C`x7lOhfx`pG3k6 >nx@"~a0|`?|p&~_|~+=)NGfHMCp~%zt$"AqAxluq@p@*f98pp?@`ppx@`ILx.:~Ty&qA~pap1 ] ?Xf8p?@x0~x@ p?p@E* ~i@\`#b`&pIx|GF [/J9|AGQ8xgxS`<J? ,p~x@` ^ `x` @EapJE SEgFx|?>|A&>!`|`T"(d|sich da ?{O tcfR)|~~7+V0cX K|xX2 H~`||Nx*f|>8 ?D,m|n sich @`p@```'>p@G9;b, ^ verfolgx ~x@@?|p;hQp0@8|~!OFTJ~|?x~CLHgTQ@N2@|qPLd@~CaXr}ber wir@`@|x,h`?E C?p` i` `@@?, $ ~>8LBxaA&rxchrittenp`xx@@?, 1C?``?~ X 4`W@ jx~`~aY  8P||x1B3AYD_ eln" "apN zA9?f?b~tlFkEC@ x R~sex`.mwW;3x Ncs`~~`?p<. ~QpcA`p|@? |x `#&|$N M><Kag8D.GGgY0h?~$r>x~xMq@~`pCctf~`Ly~|p`(8Q.}g~a 'Y4uTLqx?1p|`|?0#a|?`|xD3~ 4J+| ?|x``YbqbptupsQDx?`>-p@3L?nTsXR.:~6 \@@]`3 [x'jG#P[bJp(!Kq~|``06%V |?nIs`~p\~~s12}?` EP|N jppp?w|w ,*)@U`Z1>7|W`RqpN)`Ia@SHlfOgECK NwiOnx`>llgH@Jeqq`@~`p<* ~p ra```@?<8x|q0 plwJ@cSA;;|I~~3X w?p1q@`pGidxx\Fx~|`?`^_1-<|-~a&A@|T7Yy>?@e ~aEx?@<8 31@|@dB?|xp?`1^mo!'~A3 xC?|W[S]q~A@0x1vyCU ~ iq`?~~|)`|jF k`X@'5xfx' |B,>'0K9|`+y%bsTpxGAy8vyH@Q~x`f\EC`j>Fl :XqA<,I?x}`f@jfyxp``@p<[ |s~0l_q```~@rx|@o\o@]qkpQ\ D@?de)x `8*Gf~:xAx@|sLFa=cfcx@?p0y C@,Mg-|&0XP~~@?xX@ D|<&B$LpGAHv#br`?Chaos is`@px@`lw(#pYc`pxP@$kp|p~AY B@c@|ppaFPb0jZl?RFx~?~?x|C48<~Cu1Hq@`Ob!5 0EX|?<`x~|0|@p`bW`N$@;Pqp? (}eAH x% #BEGI~x?@?p`~f!|@yByApx`spA(D``xp~Ay`q !G~`GY7V(Fhr dem Ze|s% hB0sdx`@ - |P8D@y`IpHR`~|p@p?~PpRpB(>2` -END; - t`6p<~x?@x`G3 X~ &@pB)0m(ax`~pp~p'HQ<P +read(l+^>`/stwtx`p?p] &u`_ @Ca|~1 I({ p|p?`&f(x~@ QA@@|*) % %0&D"P0@@ t5=p?`|aDD!fF?@/!pTA?`3* |d|@|`?x `p7)4`R1`2xge_koppl`~|~?`?xx@O) `b8|~|`|  d b|@x~c@TAu`x@xO' ;>px~_4Dr!B|/~x18r!} zrite('si~?|~|CD?`KK0&Fx~xbV` a"7|@0THCa@MDNa@ Td F~8; recht~`p`|.l`dCqApp@Y8 )`p|p~AiiP=L,R?@`Ci, G 2Otameter :x3 &G u pf #|`@X }'xP8g>1jppIhp~|xxp~IF!kp ',st); x7@@w+d?`/4 @@x@x`cc``h`d~paYqM|?`|x|?~xC2^`=8|@?xiRAPJ>A2|@p4r@bxG2Apx>@@ sB#xqurde ber|`?``?x7|Ix@`xpx5  x ea?xp~C}rp@O0 Ha|?`G3Q@ Ca"Lter Lebex 0@ 0> TP}kp|kt '~x`Bx1 @E P3|x`%$FPB `  @`@ 0S L`  x}VD|paqp! 0!O~@~p@pq@~x@ ~N@%AP0x?pA @9G3Gt@q| "H|+b3(8DeC X~|``"g@- @L~W`@?p nxO`8$ g@@@PLqTrWxatxImd`t0pCdxp~|p#AqN@`Rqy9I8`?a3 !"  $f?x#`@@3Sx`OE Nq|0` ZVa``p A~N2G+x<tRyx|@@x38ECG]8" I$|A?0a%a]|A@~@ld%p<8LLT~~0#(! ,x~~?pxpN@F 80:E0\y#v(@XeB?~~|NiE(sPqfx<,ABG~`|~6 tl~?Dw&e|' @j!` A ",yg~x@p%x1fC i`&]@~B;x?|~x|@?Xt,$9BC??H|`@?||px||0 rf@|?x~#s"* gt~!Tm+Cs@rg3Z  p?|a jt|@ia?8 8A T}h Cx~@ |g!"~`|pih?@xhxxp|x@(E H(>``#\2tP09hx~`~a)&"!qY?x00@xx @`4p=caF`|x@`@|g~>Rx@?`px?<"C|KjApx~Cq9%|x@G3@> ' Pp8AA@PqAx@8Bq@?@0a?@&4vCAy>.`@Sax@x|@|@|Q8VTGubp(BK~o,$ c5i%b@?@@~@lF_@<8\|?\ 9gt$ |9~?@x|pN-HFxEHp(s @5(+`N c~|#P (s| fp mx~`|b@#\?@?#Pm|.@@Y @@h 9r?x8xo @4|c~!@ha`T*(x|C~~@L|!5&$Mapgap@?|p`;#0x`|x0h@,9`?~?x~#r|~ayV,(A% r|/e/Xx p5 |?@?|~~a| |,1@%fa> N&bAx~p`a,|E Qppph 8Pyxx|x|8c@E>@@@4Bk02{x~`~a @|a#xFx`f`eyGr)@N6<@||`?@`?|QB  PfUFMx`r!0Ey (/BI8p`?@|@. @e<<<\x@G m#z5`@~?`~|pOB,s?@@wk1 b>bJ`$0q@~x8 *sc)c`@O% 0PaA ~p|@+Px{p`G]DQdJ|t: bei ?\8!xAF`?|p ~'0 <la|A3FE+|a<|@|?@a|?|`l5&HhDMqoder seh``p?@?x`?x``K 1xx?`C|p824Kp~x~# 4@@.fpa4&0 HIr auch k@3yg*@OR ~`~~|~C*  > |#`Ys`U96qay`x~xp$xf?mC?pQ!hx0y{ssig A@ `sp|p  Pvp'( @~xx~`|xq b| x ` p` EX~1@cP @:<$@p?r"@ d% B ~:8x~p?p@A`@p' ,~=a@"lC@ fDx)6 HA@g}Bh$i$@  @qpJ`Gr  ixx?`@x2e$3~)8px$VC~@p`GM8P0p3@|?pCc` d:p@ @!rs4>`NQqpP*~|xp`|f v8`'X||`GJMA~O`0cqpa&H7 ?X"P`z@f @0( @<x``?p4xX0rpB@'`?8@b,IOG$(" @A|E`p@ca>`C @FG `~x|xx|`@?pAy?8K \\JP~~Ch@0~G@xA CFmI(@\sK yz?H@ A&|xL}l@PJdA~~p+8@c V0DFkx |`G3$ @$AVP;#8DN@~S `B@@p?@OP@C P@p Jc`As"ar_h  x9`363&KALxp8%pODp~||?xp1P@& 8x@ :F>@``W 8A@ ?0F!|p?p8H,140 0.1@. NH$` \s<@@` ~|~8$q ~ ;|` @Bq|@@F`u%D`"`g `GDhZP Pq`@'<20pL~p@ j?pLx}|`"F|pHj K5 O Ha !TF;LI@`4@P`z@*b 3`?G~`~|p8VhB`DdxO|0J^~O0AA@ ~G ~A}PhpI2!48@?X>&rpc_N@CF? ~||xpxai`UHh|GD3LDR3A>@h@8jA 0Q3@{ b@+~x?7 | M`2p@8+t@0{w0t`jGxa1tD)`"@{$ } P$Dc@`p?@G*PG X`=<`xA3 (;\ Fx xh@(k8&B2&|0! P}pp90zcPp`xx?@|?| P x8x@$G>@``'C" Q1P?p?pq0 @@0cg`@yA!|'@\HC Tqx{` ~|@P ?H9|Nqx~`@;H>"!qa.@g9xO  eM3@ !P`rpp+@6|@ax?~~px pd0 ?U`p P A<|p @C~XpKa~ B.j:Lw@$r@!bp#1`GxC~~ppJBtsR@|G}X"Gh`   XA"@T (c"@A(` @ bOs#(Ic@X ~ T<|p`?8@vp$f?B gCKc@?pT8 xT }t-@ (PcdFp!A@EG>pacg I ~~~p`xad|8`@d BYBw@x9P=jA| @@@L} lP(TT3@@8P%~x@As2Hx5 M< |Ax?XpJ qS` B p   P?pS 21A`@J yD~K9q`px`G!gaGQ@@0yO ` w~?A3$A0q @H @Hf`6F8; A~qpd$8 bxx?@~N0|8x C>@p`GP  h1B L|x?pa#s }@Gx F@hiO5Rqx?!'~|p`@ N? h8xB8x~p`Or|G`ZacqxpN@ p'K9C `hspx(tx?B1~`x?p@|p @~@pyAbx?`)V@P?02Na|xP,C: X!`?0L@f|?*H ?@|~p?p8PI+ i|g@[Ya`ypoo`( @(? %"dbyw!ppE? K |7@mR|x`?8BH|1*i gAjp?p?@`M@@0:p 4 Nb C@[ `t\x`Hp@ ~paq(D@8B$~~p`pa,(zx8xF\G? 3`?x HraGS4xW D(z8d@3F *yB ^ ~|`a8 `M oB >@~? FcarGh@0 q5@bp < `Ni6- P@D^  @']q`|x`c @=OB`Py+!@t@A3E! 0t"A @ :F?@!gEH@@Gt`&hxAG~p@CgqZwxXp@ ?`9 LqKx`xH`ea' Jc  U60sX@ ~1<_yP/Bcpp @@?`SLV"8_g?xpxlG2VMX@DzGG?@c`~|?|8itxA3> &,s|@vb eS0f7z}gc&`DI9 < @?@gp@px|x~|~pp~@|@?@px~s@?~0|||@g|`@@~@ @@8Pp`@x`p@|x@( `c@@ pTGIMMzCm@F 3xp?|x13n#`?Pq h0p`1ID"c'MyD!(fC$t3~# @G:E|60qXG|?`XpD !>~`(`pIzQ` @ V"KJ @s(V~ f>` b 0`a0||?|~?Op`E@`1xx(~@~`'@ "% ppqqC8  @0eAP@`Z@|1@)(F` 08>Hz~|p?0Pu@!| Fpp@CqO@P|_ @< $\B' @sYI~Vf$|61`@v >`p~p`Q:$<>X'x@ @K}y~>H qZ@cf_C$Mp/cKxc`Y BC?NxFC||?pNbxWppG X $a8s0@ @#vL"\$@~/#B(, ~||F D@B3xAGs@`` @PY |pa8{ 5| zz8@@RN 2~|x?0:@ 4 cx?|@60 p @ 8@pRAI|0I'J5@=WcX !~V+@``?x ] ~@"Ya~p@yxNA|Xp`f@ x(~#Xxx< HN  McG @ 49sQ | `r8@,c p@Fx|pDa}W@!b|pO@ Ap c< @ @6`Pb0P}' XmCnP|~(]8ps` 0q'y|p@`??px :`-$J@2`. `8N 0@ $#(@E?` #!Qra~`~" df l@~`|x|~`1pa?x |@8[1( xCE(p(8@G9 >x @(0cbA0 @gde @@ x !@|n|x~< q?,`LJ$B? |`pL 1~{^M@4 @^ep (3@ha!F@?p?@c!6~A)Q `E N|?ASH rOp  0sqj !%3 @|@" | @`|0$ p1xp@?|p~`? `? ` @ ?~x p`E @?`?~?~~x>`?~~@@@@~|? @~?p?x`~p? @@?` @x`@~`@@xpb@p"`x~n```?``@xdxx~?D`~~@?`?p@~@P`@@|@x|@ppp @ppp~@~x?~x?`|~@C?p``|`?p@p?@p?|`?p`?p`~x?`|~@C~x?p~@pp @pp@px|@|@~@P`@`?p@~@?`~~?D@xdxx`?````b@p"`x~nxp~`@@ @@?` @x`@~p??x` @~?p~|?@@~~x>`?~~@@`?~?|x?@?pqp~?|@`x p|`? x ~BxH$p`xx x`|@ `?@p` `x|x?xx`p`@`|@Jpx~` |<|?@`p?p?xh|<x@>@~@xp@`x ~?|pqp|x?@?x`p`xx BxH$~ x |`?Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM F^pp?x xxp @ @`~~~?|&x~x@x|@xx@pp@x|@&x~x@~?|~@?@gp@px|x~xxpp?x pp@@pxx@|`p`@x8Pp@ @@@@~|`0|||@g@?~spx~@?@|pp~@~~|@?@gp@px|x?|pp1xp@0$ |" | @`@|@@? p`E ?~x  `? ` @~`?xh|<x@>@~@?xp?p |<|?@`~`px`@`|@J`p?xx`?@p` `x|x|@ auf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 30   Alle Programme auf dieser Diskette sind dem Buch   *************************************************  * *  * K.-H. Becker und Michael Doerfler *  *  Viel Spass beim Experimentieren !  8Karl - Heinz Becker, Michael Doerfler  rden.   Speichern Sie das Programm unter einem neuen Namen, uebersetzen  Sie es mit dem Compiler, und lassen Sie es laufen.   Mit dem Programm "slideshow" koennen Sie die vorhandenen  und die selbstgemachten Bilder betrachten.  ingabe.  ( )   Loeschen Sie die nun doppelt vorhandenen Teile.   Ueberzeugen Sie sich vorsichtshalber, dass saemtliche  - Konstanten,  - Typen,  - Variablen,  - Funktionen und  - Prozeduren vereinbart wudes  Hauptprogramms, und loeschen Sie die andere (Loeschen mit fuer  delete)   Kopieren Sie sich fuer die drei Teilprobleme  - eingabe,  - berechnung,  - ausgabe  jeweils ein passendes Programmteil, z.B. PB2.9 fuer die E Die meisten Programme muessen aus den Einzelteilen zusammengesetzt  werden. Dazu bietet sich folgendes Kochrezept an :   Laden Sie PB2.7 in den UCSD-Editor ( )   Entscheiden Sie sich fuer eine der beiden Versionen Pascal-Texte des Buches mit  Ausnahme der Programmbeispiele 3.5 ff, die fuer andere Rechnertypen  gedacht sind.   Einige Programme sind vollstaendig, diese brauchen nur compiliert zu  werden.  rerseits haben wir dann eine Rueckkopplung ueber die  Verbreitung und Anzahl der Experimentatoren.  Und das spornt uns an !     Hier ein paar Hinweise zur Benutzung unter UCSD-Pascal  auf dem Apple ][ :  Sie finden auf der Diskette saemtliche Benutzer  wollen wir von Zeit zu Zeit mit neuen Informationen versorgen.  Es ist also auch Ihr Vorteil, bei uns registriert zu sein.  Es duerfte selbstverstaendlich sein, dass wir die Namen  nicht weitergeben und auf Wunsch auch wieder loeschen.  Ande"von 30,00 DM auf das Konto 4812 63-200 beim "Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, "M.Doerfler, Sonderkonto, Ritterstr. 17, 2800 Bremen 1.  + Oder loeschen Sie die Diskette.   Alle bei uns eingetragenen "registrierten" sicher kennen.   + Wenn Sie diese Diskette bei uns bestellt haben, "ist daher alles in Ordnung. "  + Wenn Sie allerdings die Diskette "schwarz" kopiert "haben, ueberweisen Sie die Benutzungsgebuehr 04461-6 *  * *  *************************************************   entnommen.   Wir moechten Sie auch gleichzeitig auf die Urheber-  rechte (Copyright-Vorschriften) aufmerksam machen,  die Sie ja *  * Computergrafische Experimente mit Pascal *  * *  * Chaos und Ordnung in Dynamischen Systemen *  * *  * VIEWEG - Verlag 1986, ISBN 3-528-F^«s) / xpunkte; $deltay := (oben - unten) / ypunkte; $REPEAT &fertig := false; &zaehl3 := 0; &zaehl1 := zaehl1 + 1; &IF (zaehl1 > xpunkte) THEN BEGIN (zeichne; (zaehl1 := 0; zaehl2 := zaehl2 + 1; &END; &rechne(zaehl1,zaehl2); $UNTIL (zaehl2 > ypul0 := zaehl1 + 2 * zaehl2; $zaehl3 := trunc(faktor * zaehl3) + 2 * zaehl2 - 1; $IF (hoch[zaehl0] < zaehl3) THEN hoch[zaehl0] := zaehl3; "END; "  PROCEDURE berechne; "BEGIN $zaehl1 :=-1 ; $zaehl3 := 0 ; $zaehl2 := 0 ; $deltax := (rechts - link&y := 2.0 * x * y - c_imaginaer; &x := xhoch2 - yhoch2 - c_reell; &xhoch2 := x * x; &yhoch2 := y * y; &quadr := xhoch2 + yhoch2; &IF (quadr < grenze2) THEN zaehl3 := anzahl; &fertig := (quadr > grenze1) OR (zaehl3 = anzahl ); $UNTIL fertig; $zaehzaehl2 : integer); "BEGIN $zaehl3 := 0; $ $c_reell := links + zaehl1 * deltax; $c_imaginaer := unten + zaehl2 * deltay; $ $x := xanfang; $y := yanfang; $ $xhoch2 := x * x; $yhoch2 := y * y; $REPEAT &zaehl3 := zaehl3 + 1; ockel wird rechts gezeichnet : } $IF zaehl2 = ypunkte THEN BEGIN &pencolor(none); moveto(turtlex + 2,hoch[200 + 2 * zaehl2]); &pencolor(white); moveto(xpunkte + 2 * ypunkte,2 * ypunkte); &moveto(xpunkte,0); $END; "END; "  PROCEDURE rechne(zaehl1,turtlex - 2, merkalt); $merkalt := merkneu; $ ${ Der Sockel wird unten gezeichnet : } $IF zaehl2 = 0 THEN BEGIN &pencolor(none); moveto(0,hoch[0]); &pencolor(white); moveto(0,0); &moveto(xpunkte,0); moveto(xpunkte,hoch[xpunkte]); $END; $ ${ Der S&moveto(zaehl0 * (200 DIV xpunkte),hoch[zaehl0]); &IF (hoch[zaehl0] >= trunc(faktor * anzahl) + 2 * zaehl2 - 2) (THEN moveto(turtlex,turtley - 1); $END; $ ${ Die Linien werden rechts geschlossen : } $merkneu := turtley; $IF zaehl2 > 0 THEN moveto(ts, $unten,oben, $x,y,xalt,yalt, $xanfang,yanfang,h,hh : real;  "PROCEDURE zeichne; "BEGIN $pencolor(none); $moveto(0,hoch[0]); $pencolor(white); $FOR zaehl0 := 0 TO 200 + 2 * zaehl2 DO BEGIN : ARRAY[1..34] OF tdaten; $filename : string[20]; $hoch : ARRAY [0..400] OF integer; $grenze1,grenze2, $c_reell,c_imaginaer, $xhoch2,yhoch2, $quadr,faktor, $deltax,deltay, $links,rech: string[20]; ,END; & "VAR $merkalt,merkneu, $zaehler,anzahl,grzy, $ypunkte,zaehl0,bildzahl, $zaehl1, zaehl2, $zgrenze, $zaehl3,hoehe : integer; $fertig : boolean; $ch : char; $satz  (*$S+ *)  PROGRAM schraeges_apfelmaennchen; "USES $turtlegrafics; "CONST $xpunkte = 200; "TYPE $tdaten = RECORD .links,rechts, .oben,unten, .yanfang, .xanfang : real; .anzahl, .ypunkte,hoehe : integer; .name auf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 36 Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM nkte) ; "END;   "PROCEDURE eingabe; (* passend zur Sammeleingabe *) "BEGIN $links := satz[zaehler].links; $rechts := satz[zaehler].rechts; $unten := satz[zaehler].unten; $oben := satz[zaehler].oben; $anzahl := satz[zaehler].anzahl; $ypunkte := satz[zaehler].ypunkte ; $IF ypunkte > 39 THEN ypunkte := 39; $hoehe := satz[zaehler].hoehe ; $faktor := hoehe / anzahl; $xanfang := satz[zaehler].xanfang; $yanfang Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM O^blockwrite(f,bild.zeiger^,16); $close(f,lock); "END;    BEGIN "sammeleingabe; "FOR zaehler := 1 TO bildzahl DO $BEGIN &eingabe; &berechne; &ausgabe; $END;  END.   (einlesen; "END; " " "PROCEDURE ausgabe; $VAR &inout : integer; &f : FILE; &bild : RECORD CASE boolean OF 0true : (adresse : integer); 0false : (zeiger : ^integer); .END; "BEGIN $bild.adresse := 8192; $rewrite(f,filename); $inout := l>17 THEN write('und #4: '); $writeln('noch genuegend'); $writeln('Platz ist ? '); $writeln('Sonst neue Diskette(n) einlegen und .'); $read(ch); writeln; $IF NOT(ch IN ['j','J','y','Y']) &THEN exit(PROGRAM); $FOR zaehler := 1 TO bildzahl DO $grenze2 := 1.0E-6; $writeln('Wieviel Zeichnungen nacheinander ? '); $write('maximal 34 > '); readln(bildzahl); $IF bildzahl < 1 THEN exit(PROGRAM); $IF bildzahl > 34 THEN bildzahl := 34; $writeln; $write('Ist sicher, dass auf #5: '); $IF bildzah'#4:'); &readln(filename); &IF length(filename) > 7 (THEN filename :=copy(filename,1,7); &IF zaehler < 18 (THEN name :=concat('#5:',filename,'.FOTO') (ELSE name :=concat('#4:',filename,'.FOTO'); $ END; $END; " "BEGIN $grenze1 := 100.0; &writeln;write('yanfang > '); readln(yanfang); &writeln;write('xanfang > '); readln(xanfang); &writeln('Unter welchem Namen abspeichern ?'); &write('(max. 7 Buchstaben > '); &IF zaehler < 18 (THEN write('#5:') (ELSE write(n); &writeln;write('oben (<=1.5) > '); readln(oben); &writeln;write('Wiederholungen (50)> '); readln(anzahl); &writeln;write('Linien hintereiand.> '); readln(ypunkte); &writeln;write('Hoehe d Zeichn(<50)> '); readln(hoehe); riteln; &writeln('Eingabe der Parameter '); &writeln('fuer das ',zaehler,'. Bild :'); &writeln;write('links (>=-2) > '); readln(links); &writeln;write('rechts (<=3) > '); readln(rechts); &writeln;write('unten (>=-1.5) > '); readln(unte := satz[zaehler].yanfang; $filename := satz[zaehler].name; $initturtle; " fillchar(hoch,sizeof(hoch),chr(0)); "END;   "PROCEDURE sammeleingabe; (* Version 1 *) ( $PROCEDURE einlesen; $BEGIN &WITH satz[zaehler] DO BEGIN &writeln;wauf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 36  (*$S+ *) PROGRAM irgendein_sinnvoller_Name; "USES $turtlegrafics, $transcend; $(* gegebenenfalls muessen weitere Bibliotheken ergaenzt werden *)  "CONST $xpunkte = 279; $ypunkte = 191; $(* gegebenenfalls muessen weitere Konstanten ergaenzt wern('Platz ist ? '); &writeln('Sonst neue Diskette(n) einlegen und .'); &read(ch); writeln; &IF NOT(ch IN ['j','J','y','Y']) (THEN exit(PROGRAM); &write('c_reell > '); liesreal(c_reell,-5.0,5.0); $writeln; $write('c_imaginaer > '); liesln('Wieviel Zeichnungen nacheinander ? '); &write('maximal 34 > '); readln(bildzahl); &IF bildzahl > 34 THEN bildzahl := 34; &writeln; &write('Ist sicher, dass auf #5: '); &IF bildzahl>17 THEN write('und #4: '); &writeln('noch genuegend'); &writel (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " $ $PROCEDURE erstes_bild; $BEGIN &stelle := 'A'; &writeln(' Z O O M '); &write2 := satz[zaehl1].grenze2; $anzahl := satz[zaehl1].anzahl; $filename := satz[zaehl1].name; $initturtle; "END;  " "PROCEDURE sammeleingabe; (* Version 2 *)  (* Programmbeispiel 2.15 aus *) obergrenze); !END; PROCEDURE eingabe; "BEGIN $links := satz[zaehl1].links; $rechts := satz[zaehl1].rechts; $unten := satz[zaehl1].unten; $oben := satz[zaehl1].oben; $grenze1 := satz[zaehl1].grenze1; $grenze&IF (zahl < untergrenze) OR (zahl > obergrenze) THEN (BEGIN *write(chr(7)); (* Bell *) *writeln('Bitte im Intervall ',untergrenze,' bis ', *obergrenze,' bleiben !'); *write('Neueingabe > '); (END; #UNTIL (zahl >= untergrenze) AND (zahl <=  (* Programmbeispiel 2.11 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " $BEGIN $REPEAT &realreadln(zahl); ); .IF komma THEN faktor := faktor * 0.1; ,END *ELSE IF (buchstabe = '.') OR (buchstabe = ',') 1THEN komma := true; &END; $zahl := zahl * faktor; "END; " " "PROCEDURE liesreal(VAR zahl : real; untergrenze,obergrenze : real);  .0; $komma := false; $ $readln(wort); $ $IF (wort[1] = '-') THEN faktor := -1.0; $FOR zaehler := 1 TO length(wort) DO &BEGIN (buchstabe := wort[zaehler]; (IF (buchstabe in ['0'..'9']) *THEN ,BEGIN .zahl := 10.0*zahl + ord(buchstabe) - ord('0'che Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " $VAR &wort : string; &buchstabe : char; &zaehler : integer; &faktor : real; &komma : boolean; & "BEGIN $faktor := 1.0; $zahl := 0"moveto(xkoo,ykoo); "pencolor(white); "move(0)  END; (* von setze *)    $PROCEDURE realreadln(VAR zahl : real);   (* Programmbeispiel 2.10 aus *)  (* Becker / Doerfler *)  (* Computergrafisopplung, $links,rechts, $unten,oben : real; $stelle, $filename : string[20]; $satz : ARRAY[1..34] OF tdaten;   PROCEDURE setze ( xkoo,ykoo : integer);  (* Integer-Version *)  BEGIN "pencolor(none); hl3,zaehl4 : integer; $ch : char; $fertig : boolean; $p,k,x,y, $zentx, faktx, lnfx, $zenty, fakty, lnfy, $deltax, deltay, $grenze1,absqu, $c_imaginaer,c_reell, $xhoch2,yhoch2, $population, $kopplung, $delta_kden *)  "TYPE $tdaten = RECORD .links,rechts,grenze1, .unten,oben : real; .grenze2, .anzahl : integer; .name : string[20]; ,END;  "VAR $bildzahl,grenze2, $anzahl, $unsichtbar,sichtbar, $zaehl1,zaehl2, $zaereal(c_imaginaer,-5.0,5.0); $writeln; $WITH satz[1] DO (BEGIN *writeln;writeln; *writeln('Eingabe der Parameter '); *writeln('fuer das erste Bild :'); *writeln; *write('links (>= -3) > '); liesreal(links,-3.0,3.0); *writeln; *write('rechts (<=3) > '); liesreal(rechts,-3.0,3.0); *writeln; *write('unten (>=-1.2) > '); liesreal(unten,-2.5,1.5); *writeln; *write('oben (<=1.2) > '); liesreal(oben,-2.5,1.5); *writeln; *write('Iterationen > '); readln(anzahl); *writeln/ypunkte; "zaehl1 := -1; "zaehl2 := 0 ; "REPEAT $zaehl1 := succ(zaehl1); ${ IF keypress THEN sprung ELSE zaehl1 := succ(zaehl1); } $IF (zaehl1 > xpunkte) THEN &BEGIN (zaehl1 := 0; (zaehl2 := succ(zaehl2); &END; $x := links + zaehl1 * deh2 + yhoch2; "fertig := (absqu > grenze1) OR (zaehl3 = anzahl ) ;  END;  "  (* Version f}r zn+1 = zn2 - c *)  (* Julia - Menge *)  (* hier mit REPEAT-Schleife *)  BEGIN "deltax := (rechts-links)/xpunkte; "deltay := (oben-unten)"VAR zaehl1,zaehl2,zaehl3 : integer; " PROCEDURE f;  (* Version f}r zn+1 = zn^2 - c *)  BEGIN "zaehl3 := succ(zaehl3); "y := 2.0 * x * y - c_imaginaer; "x := xhoch2 - yhoch2 - c_reell; "xhoch2 := x * x; "yhoch2 := y * y; "absqu := xhocame,stelle,'.FOTO'); ,writeln(links:7:4,rechts:7:4,oben:7:4,unten:7:4,name); *END; $END; (* von alle_anderen *) & "BEGIN $erstes_bild; $letztes_bild; $alle_anderen; "END; (* von sammeleingabe *)    PROCEDURE berechnung; unc(zaehl1/bildzahl* =(satz[bildzahl].grenze2-satz[1].grenze2)); ,grenze1 := 100.0; ,stelle[1] := chr(ord('A')+zaehl1); ,IF zaehl1 < 18 .THEN name := concat('#5:',filename,stelle,'.FOTO') .ELSE name := concat('#4:',filenty)* ;exp((bildzahl-zaehl1)*lnfy); ,unten := zenty + (satz[bildzahl].unten- zenty)* ;exp((bildzahl-zaehl1)*lnfy); ,anzahl := satz[1].anzahl + trunc(zaehl1/bildzahl* =(satz[bildzahl].anzahl-satz[1].anzahl)); ,grenze2 := satz[1].grenze2+ tr(WITH satz[zaehl1] DO *BEGIN ,rechts := zentx + (satz[bildzahl].rechts - zentx)* ;exp((bildzahl-zaehl1)*lnfx); ,links := zentx + (satz[bildzahl].links - zentx)* ;exp((bildzahl-zaehl1)*lnfx); ,oben := zenty + (satz[bildzahl].oben - zenen- 0satz[bildzahl].unten-satz[1].oben); &fakty := (satz[1].oben - zenty)/(satz[bildzahl].oben - zenty); &lnfy := (ln(fakty))/bildzahl; $END; (* von letztes_bild *) " $PROCEDURE alle_anderen; $BEGIN &FOR zaehl1 := 2 TO bildzahl DO bildzahl].links-satz[1].rechts); &faktx := (satz[1].rechts - zentx)/(satz[bildzahl].rechts - zentx); &lnfx := (ln(faktx))/bildzahl; &zenty := (satz[1].unten*satz[bildzahl].oben - 0satz[bildzahl].unten*satz[1].oben)/ /(satz[1].unten+satz[bildzahl].ob 18 ,THEN name := concat('#5:',filename,stelle,'.FOTO') ,ELSE name := concat('#4:',filename,stelle,'.FOTO'); (END; &zentx := (satz[1].links*satz[bildzahl].rechts - 0satz[bildzahl].links*satz[1].rechts)/ /(satz[1].links+satz[bildzahl].rechts- 0satz[*write('oben (<=1.2) > '); liesreal(oben,-2.5,2.5); *writeln; *write('Iterationen > '); readln(anzahl); *writeln; *write('Zeichnen bis > '); readln(grenze2); *writeln; *grenze1 := 100.0; *stelle[1] := chr(ord('A')+bildzahl); *IF bildzahl = -3) > '); liesreal(links,-3.0,3.0); *writeln; *write('rechts (<=3) > '); liesreal(rechts,-3.0,3.0); *writeln; *write('unten (>=-1.2) > '); liesreal(unten,-2.5,2.5); *writeln; filename,1,5); *name := concat('#5:',filename,'A.FOTO'); (END; $END; (* von erstes_bild *) $ $PROCEDURE letztes_bild; $BEGIN &WITH satz[bildzahl] DO (BEGIN *writeln;writeln; *writeln('Eingabe der Parameter '); *writeln('fuer das letzte Bil; *write('Zeichnen bis > '); readln(grenze2); *writeln; *grenze1 := 100.0; *write('Unter welchen Namen abspeichern ?'); *write('(max. 5 Buchstaben > '); *readln(filename); *IF length(filename) > 5 ,THEN filename := copy(ltax; $y := unten + zaehl2 * deltay; $xhoch2 := x * x; $yhoch2 := y * y; $fertig := false; $zaehl3 := 0; $REPEAT &f $UNTIL fertig; $IF (zaehl3 = anzahl) OR $((zaehl3 < grenze2) AND (zaehl3 MOD 3 = 0)) &THEN setze(zaehl1,zaehl2); "UNTIL (zaehl2 = ypunkte) AND (zaehl1 = xpunkte);  END;  "PROCEDURE ausgabe; "TYPE $tbild = RECORD CASE boolean OF .true : (adresse : integer); .false : (zeiger : ^integer) ,END;  "VAR $bild : tbild;  &f : file; &inout,$faktor := 1.0; $zahl := 0.0; $komma := false; $ $readln(wort); $ $IF (wort[1] = '-') THEN faktor := -1.0; $FOR zaehler := 1 TO length(wort) DO &BEGIN (buchstabe := wort[zaehler]; (IF (buchstabe in ['0'..'9']) *THEN ,BEGIN .zahl := 10.0*za *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " $VAR &wort : string; &buchstabe : char; &zaehler : integer; &faktor : real; &komma : boolean; & "BEGIN "BEGIN $pencolor(none); $moveto(xkoo,ykoo); $pencolor(white); $move(0) "END; (* von setze *) " " " " "PROCEDURE realreadln(VAR zahl : real);   (* Programmbeispiel 2.10 aus *)  (* Becker / Doerfler lung, $delta_kopplung, $xstart,ystart, $links,rechts, $unten,oben : real; $stelle, $filename : string[20]; $satz : ARRAY[1..34] OF tdaten;  "PROCEDURE setze ( xkoo,ykoo : integer); "(* Integer-Version *) 1,zaehl2, $zaehl3,zaehl4 : integer; $ch : char; $fertig : boolean; $p,k,x,y, $zentx, faktx, lnfx, $zenty, fakty, lnfy, $deltax, deltay, $grenze1,absqu, $c_imaginaer,c_reell, $xhoch2,yhoch2, $population, $koppn *)  "TYPE $tdaten = RECORD .links,rechts,grenze1, .xstart,ystart, .unten,oben : real; .grenze2, .anzahl : integer; .name : string[20]; ,END;  "VAR $bildzahl,grenze2, $anzahl, $unsichtbar,sichtbar, $zaehl (*$S+ *) PROGRAM nochein_sinnvoller_Name; "USES $turtlegrafics, $transcend; $(* gegebenenfalls muessen weitere Bibliotheken ergaenzt werden *)  "CONST $xpunkte = 279; $ypunkte = 191; $(* gegebenenfalls muessen weitere Konstanten ergaenzt werdeauf das Konto 4812 63-200 beim Postgiroamt Hamburg (BLZ 200 100 20) K.-H. Becker, M. Doerfler, Sonderkonto, Ritterstr. 17 2800 Bremen 1. Wenn dies nicht gewuenscht ist, loeschen Sie bitte die Programme wieder. 36 Dies Programm ist aus dem Buch : Becker/Doerfler : Computergrafische Experimente mit Pascal, Vieweg 1986 ISBN 3-528-04461-6. Viel Spass damit ! Und eine Bitte : Wenn Sie die Diskette schwarz kopiert haben, ueberweisen Sie Benutzungsgeb}hr von 30,00 DM 7O^ingabe; &berechnung; &ausgabe; $END;  END. (* Hauptprogramm, Version 2 *)  zaehl1 : integer; "BEGIN $bild.adresse := 8192; $rewrite(f,filename); $inout := blockwrite(f,bild.zeiger^,16); $close(f,lock); "END;    $   BEGIN (* Hauptprogramm, Version 2 *) "sammeleingabe; "FOR zaehl1 := 1 TO bildzahl DO $BEGIN &ehl + ord(buchstabe) - ord('0'); .IF komma THEN faktor := faktor * 0.1; ,END *ELSE IF (buchstabe = '.') OR (buchstabe = ',') 1THEN komma := true; &END; $zahl := zahl * faktor; "END; " " "PROCEDURE liesreal(VAR zahl : real; untergrenze,obergrenze : real);   (* Programmbeispiel 2.11 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente mit Pascal *)  (* Braunschweig/Wieahl); *IF bildzahl < 18 ,THEN name := concat('#5:',filename,stelle,'.FOTO') ,ELSE name := concat('#4:',filename,stelle,'.FOTO'); (END; &zentx := (satz[1].links*satz[bildzahl].rechts - 0satz[bildzahl].links*satz[1].rechts)/ /(satz[1].links+satz[bild); *writeln; *write('ystart > '); liesreal(ystart ,-5.0,5.0); *writeln; *write('Iterationen > '); readln(anzahl); *writeln; *write('Zeichnen bis > '); readln(grenze2); *writeln; *grenze1 := 100.0; *stelle[1] := chr(ord('A')+bildz*write('rechts (<=3) > '); liesreal(rechts,-3.0,3.0); *writeln; *write('unten (>=-1.2) > '); liesreal(unten,-2.5,2.5); *writeln; *write('oben (<=1.2) > '); liesreal(oben,-2.5,2.5); *writeln; *write('xstart > '); liesreal(xstart ,-5.0,5.0$PROCEDURE letztes_bild; $BEGIN &WITH satz[bildzahl] DO (BEGIN *writeln;writeln; *writeln('Eingabe der Parameter '); *writeln('fuer das letzte Bild :'); *writeln; *write('links (>= -3) > '); liesreal(links,-3.0,3.0); *writeln; *write('Unter welchen Namen abspeichern ?'); *write('(max. 5 Buchstaben > '); *readln(filename); *IF length(filename) > 5 ,THEN filename := copy(filename,1,5); *name := concat('#5:',filename,'A.FOTO'); (END; $END; (* von erstes_bild *) $ t ,-5.0,5.0); *writeln; *write('ystart > '); liesreal(ystart ,-5.0,5.0); *writeln; *write('Iterationen > '); readln(anzahl); *writeln; *write('Zeichnen bis > '); readln(grenze2); *writeln; *grenze1 := 100.0; *writeln; *write('rechts (<=3) > '); liesreal(rechts,-3.0,3.0); *writeln; *write('unten (>=-1.2) > '); liesreal(unten,-2.5,1.5); *writeln; *write('oben (<=1.2) > '); liesreal(oben,-2.5,1.5); *writeln; *write('xstart > '); liesreal(xstarteln; &IF NOT(ch IN ['j','J','y','Y']) (THEN exit(PROGRAM); &WITH satz[1] DO (BEGIN *writeln;writeln; *writeln('Eingabe der Parameter '); *writeln('fuer das erste Bild :'); *writeln; *write('links (>= -3) > '); liesreal(links,-3.0,3.0); &IF bildzahl > 34 THEN bildzahl := 34; &writeln; &write('Ist sicher, dass auf #5: '); &IF bildzahl>17 THEN write('und #4: '); &writeln('noch genuegend'); &writeln('Platz ist ? '); &writeln('Sonst neue Diskette(n) einlegen und .'); &read(ch); wrimit Pascal *)  (* Braunschweig/Wiesbaden 1986 *) " $ $PROCEDURE erstes_bild; $BEGIN &stelle := 'A'; &writeln(' Z O O M '); &writeln('Wieviel Zeichnungen nacheinander ? '); &write('maximal 34 > '); readln(bildzahl); $filename := satz[zaehl1].name; $initturtle; "END;  " "PROCEDURE sammeleingabe; (* Version 2 *)  (* Programmbeispiel 2.15 aus *)  (* Becker / Doerfler *)  (* Computergrafische Experimente := satz[zaehl1].oben; $grenze1 := satz[zaehl1].grenze1; $grenze2 := satz[zaehl1].grenze2; $anzahl := satz[zaehl1].anzahl; $xstart := satz[zaehl1].xstart; $ystart := satz[zaehl1].ystart; te('Neueingabe > '); (END; #UNTIL (zahl >= untergrenze) AND (zahl <= obergrenze); !END; PROCEDURE eingabe; "BEGIN $links := satz[zaehl1].links; $rechts := satz[zaehl1].rechts; $unten := satz[zaehl1].unten; $oben sbaden 1986 *) " $BEGIN $REPEAT &realreadln(zahl); &IF (zahl < untergrenze) OR (zahl > obergrenze) THEN (BEGIN *write(chr(7)); (* Bell *) *writeln('Bitte im Intervall ',untergrenze,' bis ', *obergrenze,' bleiben !'); *wrizahl].rechts- 0satz[bildzahl].links-satz[1].rechts); &faktx := (satz[1].rechts - zentx)/(satz[bildzahl].rechts - zentx); &lnfx := (ln(faktx))/bildzahl; &zenty := (satz[1].unten*satz[bildzahl].oben - 0satz[bildzahl].unten*satz[1].oben)/ /(satz[1].unten+satz[bildzahl].oben- 0satz[bildzahl].unten-satz[1].oben); &fakty := (satz[1].oben - zenty)/(satz[bildzahl].oben - zenty); &lnfy := (ln(fakty))/bildzahl; $END; (* von letztes_bild *) " $PROCEDURE alle_anderen; $BEGIN &FOR zae"FOR zaehl1 := 1 TO bildzahl DO $BEGIN &eingabe; &berechnung; &ausgabe; $END;  END. (* Hauptprogramm, Version 2 *)  : file; &inout,zaehl1 : integer; "BEGIN $bild.adresse := 8192; $rewrite(f,filename); $inout := blockwrite(f,bild.zeiger^,16); $close(f,lock); "END;    $   BEGIN (* Hauptprogramm, Version 2 *) "sammeleingabe; setze(zaehl1,zaehl2); "UNTIL (zaehl2 = ypunkte) AND (zaehl1 = xpunkte);  END;  "PROCEDURE ausgabe; "TYPE $tbild = RECORD CASE boolean OF .true : (adresse : integer); .false : (zeiger : ^integer) ,END;  "VAR $bild : tbild;  &f er := unten + zaehl2 * deltay; $c_reell := links + zaehl1 * deltax; $xhoch2 := x * x; $yhoch2 := y * y; $fertig := false; $zaehl3 := 0; $REPEAT &f $UNTIL fertig; $IF (zaehl3 = anzahl) OR $((zaehl3 < grenze2) AND (zaehl3 MOD 3 = 0)) &THEN "zaehl2 := 0 ; "REPEAT $zaehl1 := succ(zaehl1); ${ IF keypress THEN sprung ELSE zaehl1 := succ(zaehl1); } $IF (zaehl1 > xpunkte) THEN &BEGIN (zaehl1 := 0; (zaehl2 := succ(zaehl2); &END; $x := xstart; $y := ystart; $c_imagina> grenze1) OR (zaehl3 = anzahl ) ;  END;  "  (* Version f}r zn+1 = zn2 - c *)  (* Apfelmaennchen *)  (* hier mit REPEAT-Schleife *)  BEGIN "deltax := (rechts-links)/xpunkte; "deltay := (oben-unten)/ypunkte; "zaehl1 := -1; eger; " PROCEDURE f;  (* Version f}r zn+1 = zn^2 - c *)  BEGIN "zaehl3 := succ(zaehl3); "y := 2.0 * x * y - c_imaginaer; "x := xhoch2 - yhoch2 - c_reell; "xhoch2 := x * x; "yhoch2 := y * y; "absqu := xhoch2 + yhoch2; "fertig := (absqu writeln(links:7:4,rechts:7:4,oben:7:4,unten:7:4,name); *END; $END; (* von alle_anderen *) & "BEGIN $erstes_bild; $letztes_bild; $alle_anderen; "END; (* von sammeleingabe *)    PROCEDURE berechnung; "VAR zaehl1,zaehl2,zaehl3 : int=(satz[bildzahl].ystart-satz[1].ystart)); ,grenze1 := 100.0; ,stelle[1] := chr(ord('A')+zaehl1); ,IF zaehl1 < 18 .THEN name := concat('#5:',filename,stelle,'.FOTO') .ELSE name := concat('#4:',filename,stelle,'.FOTO'); , := satz[1].grenze2+ trunc(zaehl1/bildzahl* =(satz[bildzahl].grenze2-satz[1].grenze2)); ,xstart := satz[1].xstart+ trunc(zaehl1/bildzahl* =(satz[bildzahl].xstart-satz[1].xstart)); ,ystart := satz[1].ystart+ trunc(zaehl1/bildzahl* atz[bildzahl].oben - zenty)* ;exp((bildzahl-zaehl1)*lnfy); ,unten := zenty + (satz[bildzahl].unten- zenty)* ;exp((bildzahl-zaehl1)*lnfy); ,anzahl := satz[1].anzahl + trunc(zaehl1/bildzahl* =(satz[bildzahl].anzahl-satz[1].anzahl)); ,grenze2 hl1 := 2 TO bildzahl DO (WITH satz[zaehl1] DO *BEGIN ,rechts := zentx + (satz[bildzahl].rechts - zentx)* ;exp((bildzahl-zaehl1)*lnfx); ,links := zentx + (satz[bildzahl].links - zentx)* ;exp((bildzahl-zaehl1)*lnfx); ,oben := zenty + (sM O^rtarkschrift..  ; Falls die Option gewuenscht ist, wird Bit 7 gesetzt.  ; In Bit 6 wird ggf. der erste bzw. zweite Duchlauf  ; festgehalten.  ; Falls Seite 2 gewuenscht ist, wird in einem Unterprogramm  ; die Liste der Zeilenanfangsadressen geaendert. ------------------------------------ (POP RETURN ; return-adresse wird in 00 und 01 aufbewahrt   ;-------Parameteruebergabe---------------------------------------------- (  ; Es werden vier Flags angelegt, fuer Breit, Hoch, Invers und  ; fuer S DUGH .EQU 35 ; MSB Druckeruebergabe-adresse   ;-------Adressen - Imagewriter /Interface 6551/ -----------------------  CTLREG .EQU 0C09B  CMDREG .EQU 0C09A  STREG .EQU 0C099  TDREG .EQU 0C098  ;-----------------------------------U 1E  BS5 .EQU 1F  BS6 .EQU 20  BS7 .EQU 21  DFGL .EQU 32 ; LSB Druckerfreigabe-adresse  DFGH .EQU 33 ; MSB Druckerfreigabe-adresse  DUGL .EQU 34 ; LSB Druckeruebergabe-adresse .EQU 0C  ZP2 .EQU 0E  ZP3 .EQU 10  ZP4 .EQU 12  ZP5 .EQU 14  ZP6 .EQU 16  ZP7 .EQU 18  BS0 .EQU 1A ; speichern 8 Byte  BS1 .EQU 1B ; "uebereinander"  BS2 .EQU 1C  BS3 .EQU 1D  BS4 .EQckzeilen  BYTEZ .EQU 03 ; 0..39. zaehlt Bytes pro Zeile  BREIT .EQU 04  HOCH .EQU 05  INVERS .EQU 06  STARK .EQU 07  AUSGABE .EQU 09 ; speichert das auszugebende Byte  ZP0 .EQU 0A ; Zeilenanfangspointer  ZP1  ; + 8 : page 2, sonst page 1  ; +16 : Starkschrift fuer verbrauchte Farbbaender   ;-------benutzte page 0 Adressen----------------------------------------   RETURN .EQU 0  ZEILZ .EQU 02 ; 0..23. zaehlt Drueter steuert die Art des Ausdrucks :  ; 1 : doppelt breit,  ; 0 : einfach breit  ; dazu:  ; + 2 : doppelt hoch, sonst einfach  ; + 4 : invers, sonst normal nterface  ;o (.PROC HCIMAGE,1  ;o  ;o die '1' sagt, dass 1 Wort uebernommen wird.  ;oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo   ; PROCEDURE HCIMAGE (PARAMETER : INTEGER); EXTERNAL;  ;  ; Der Param ; (TDREG) (.ENDM ( (.MACRO POP (PLA (STA %1 (PLA (STA %1+1 (.ENDM ( (.MACRO PUSH (LDA %1+1 (PHA (LDA %1 (PHA (.ENDM (  ;oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo  ;o Hardcopy fuer IMAGEWRITER mit SSC-I(; Aenderungen 2.86 D.Mueller ( (.MACRO RAUS ;fuer Imagewriter - SSC -  $01 LDA @DFGL,Y ; Status test (STREG) (AND #10 ; ready ? (BEQ $01 (JSR WAIT ; ohne Warten geht es nicht (LDA #%1 ;Senden (STA @DUGL,Y  (LDA #0 (STA BREIT (STA HOCH (STA INVERS (STA STARK ( (PLA (ROR A (ROR BREIT (ROR A (ROR HOCH (ROR A (ROR INVERS ( (ROR A (BCC SEITE1 ; p steht noch im CARRY (PHA (JSR MAKEP2 ; dort werden Startadressen veraendert  PLA  SEITE1 ROR A (BCC HOLMSB (ROR STARK   HOLMSB LDY #00 ; fuer indirekte Adressierung (PLA ; MSB des Parameters wird verworfen   BIT 0C010 ; Tastenregister loeschen (  ;-------Druckeradressen(LDA HOCH (EOR #40 (STA HOCH (BIT HOCH (BPL WEITERZ ; wenn Bit 7 = 0 (BVC WEITERZ (JMP HOL7A (  WEITERZ INC ZEILZ (LDA ZEILZ (CMP #18 ; = 24. (BNE NEU ( (JMP ABSCHL (  NEU JMP NEUZLE ( (   ;-------Abschalten------------- raus damit ! ( (BIT BREIT (BPL SCHMAL (LDA BREIT (EOR #40 (STA BREIT (BIT BREIT (BVS WARTE ( (  SCHMAL DEX (BNE RAUSMIT ( (INC BYTEZ (LDA BYTEZ (CMP #28 ; = 40. (BNE HOL7B ( (RAUS 0D ; 'CR' (RAUS 0A ; 'LF' (  WARTE LDA @DFGL,Y ; Drucker frei ?  ; BMI WARTE (AND #10 (BEQ WARTE (JSR WAIT (LDA @DFGL,Y (AND #10 (BEQ WARTE ( (LDA AUSGABE (BIT INVERS (BPL NORMAL ; normal oder invers ? (EOR #0FF  NORMAL STA @DUGL,Y ; na endlich ! (ROR AUSGABE (LSR BS2 (ROR AUSGABE (LSR BS3 (ROR AUSGABE (LSR BS4 (ROR AUSGABE (LSR BS5 (ROR AUSGABE (LSR BS6 (ROR AUSGABE (LSR BS7 (ROR AUSGABE ( (LDY #00 ; fuer indirekte Adressierung noetig Grafikzeichen   HOL7B BIT HOCH (BPL EINFACH  DOPPELT BVS MAL2  MAL1 JSR B7OBEN ; beim ersten Durchgang (JMP RAUSM (  MAL2 JSR B7UNTEN (JMP RAUSM   EINFACH JSR B7EINF  (  RAUSM LDX #7  RAUSMIT LSR BS0 (ROR AUSGABE (LSR BS1 KLN (RAUS 35 ; "5" (RAUS 36 ; "6" (BNE GRS  KLN NOP (RAUS 32 ; "2" (RAUS 38 ; "8"  GRS NOP (RAUS 30 ; "0" 8; ESC S 0280 oder ESC S 0560 (bei Breitdruck) ( ; jetzt kommen 280 bzw 560 (CPX #10 ; = 16. (BNE HOLADD (  HOL7A LDA #0 (STA BYTEZ ( (LDY #00 ; fuer indirekte Adressierung (RAUS 1B ; "ESC" (RAUS 53 ; "S" (RAUS 30 ; "0" (BIT BREIT ; testet Bit 7 : gross oder klein ? (BPL WEITER LDA ZEILZ (ASL A (ASL A (ASL A (TAY  LDX #00   ;------------------------------------------------------------------------------  HOLADD LDA ZEILLO,Y (STA ZP0,X (INX (LDA ZEILHI,Y (STA ZP0,X (INY (INX   ;--------------------------------------  ; naechste Zeile  ;--------------------------------------   LDA #0 (STA ZEILZ  NEUZLE LDA 0C000 ; Taste gedrueckt ? (CMP #09B ; 'ESC' (Bit 7 on) (BNE WEITER (JMP ABSCHL ; 'ESC' (RAUS 3E ; '>' unidirektionaler Druck ( (RAUS 1B ; 'ESC' (RAUS 6E ; 'n' 72 dots/inch; 576 dots/line ( ; (gleicher Punktabstand horizontal & vertikal)  ;RAUS 0D (;RAUS 0A (RAUS 5A ; 'Z' (RAUS 00 ; '0' (RAUS 20 ; '32' : ESC Z 0 32 -->'8 Bit-Daten' ( (RAUS 1B ; 'ESC' (RAUS 54 ; 'T' (RAUS 31 ; '1' (RAUS 36 ; '6' : ESC T 16 --> 16/144 = 1/9 " Linefeed ( (RAUS 1Bt (STA CMDREG   ;-------Drucker initiieren---------------------------------------------- ( (RAUS 00 ; '0' ( (BIT STARK (BPL NIST (RAUS 1B ; 'ESC' (RAUS 21 ; Starkschrift (  NIST NOP (RAUS 1B ; 'ESC' ; STREGH Status-Reg. (STA DFGH ; fuer Imagewr. C098 (   ;-------Interface initiieren gilt nur fuer SSC mit 6551 ----------------  (LDA #1E ; 9600 Baud, 8 Bit, 1 Stop Bit (STA CTLREG (LDA #0B ; keine Paritae ------------------------------------------------  ( (LDA #98 ; TDREGL (STA DUGL  LDA #0C0 ; TDREGH Transmit-Reg. (STA DUGH ; fuer Imagewr. C098 ( (LDA #99 ; STREGL (STA DFGL ; (LDA #0C0 ------------------------------------------------ ( (  ABSCHL LDY #00 (RAUS 1B ; 'ESC' (RAUS 22 ; '"' --> Abschalten Starkschrift (RAUS 1B ; 'ESC' (RAUS 41 ; 'A' --> 1/6 " Zeilenvorschub (RAUS 1B ; 'ESC' (RAUS 3C ; '<' --> Bidirektionaler Druck (RAUS 1B ; 'ESC' (RAUS 45 ; 'E' --> Elite-Schrift 96 dpi (RAUS 1B ; 'ESC' (RAUS 44 ; 'D' (RAUS 00 ; = 0 (RAUS 20 ; = 32 ahl); *IF bildzahl < 18 ,THEN name := concat('#5:',filename,stelle,'.FOTO') ,ELSE name := concat('#4:',filename,stelle,'.FOTO'); (END; &zentx := (satz[1].links*satz[bildzahl].rechts - 0satz[bildzahl].links*satz[1].rechts)/ /(satz[1].links+satz[bild); *writeln; *write('ystart > '); liesreal(ystart ,-5.0,5.0); *writeln; *write('Iterationen > '); readln(anzahl); *writeln; *write('Zeichnen bis > '); readln(grenze2); *writeln; *grenze1 := 100.0; *stelle[1] := chr(ord('A')+bildz*write('rechts (<=3) > '); liesreal(rechts,-3.0,3.0); *writeln; *write('unten (>=-1.2) > '); liesreal(unten,-2.5,2.5); *writeln; *write('oben (<=1.2) > '); liesreal(oben,-2.5,2.5); *writeln; *write('xstart > '); liesreal(xstart ,-5.0,5.0,0A8 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 8,50 (.BLOCK 8,0D0 (.BLOCK 20,0 + (.END  (.BYTE 23, 27, 2B, 2F, 33, 37, 3B, 3F, 23, 27, 2B (.BYTE 2F, 33, 37, 3B, 3F  ZEILLO .BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,0 (.BLOCK 8,80 (.BLOCK 8,28 (.BLOCK 8,0A8 (.BLOCK 8,28 (.BLOCK 8(.BYTE 27, 2B, 2F, 33, 37, 3B, 3F, 20, 24, 28, 2C (.BYTE 30, 34, 38, 3C, 20, 24, 28, 2C, 30, 34, 38 (.BYTE 3C, 21, 25, 29, 2D, 31, 35, 39, 3D, 21, 25 (.BYTE 29, 2D, 31, 35, 39, 3D, 22, 26, 2A, 2E, 32 (.BYTE 36, 3A, 3E, 22, 26, 2A, 2E, 32, 36, 3A, 3E (.BYTE 28, 2C, 30, 34, 38, 3C, 20, 24, 28, 2C, 30 (.BYTE 34, 38, 3C, 21, 25, 29, 2D, 31, 35, 39, 3D (.BYTE 21, 25, 29, 2D, 31, 35, 39, 3D, 22, 26, 2A (.BYTE 2E, 32, 36, 3A, 3E, 22, 26, 2A, 2E, 32, 36 (.BYTE 3A, 3E, 23, 27, 2B, 2F, 33, 37, 3B, 3F, 23 29, 2D, 31, 35 (.BYTE 39, 3D, 21, 25, 29, 2D, 31, 35, 39, 3D, 22 (.BYTE 26, 2A, 2E, 32, 36, 3A, 3E, 22, 26, 2A, 2E (.BYTE 32, 36, 3A, 3E, 23, 27, 2B, 2F, 33, 37, 3B (.BYTE 3F, 23, 27, 2B, 2F, 33, 37, 3B, 3F, 20, 24 WAIT2 (DEX (BNE WAIT1 (PLA (TAY (PLA (TAX (RTS   ;------------------------------  ; Zeilenanfangsadressen  ;------------------------------   ZEILHI .BYTE 20, 24, 28, 2C, 30, 34, 38, 3C, 20, 24, 28 (.BYTE 2C, 30, 34, 38, 3C, 21, 25, EP2 LDY #0C0  LOOP DEY (LDA ZEILHI,Y (CLC (ADC #20 (STA ZEILHI,Y (BNE LOOP (RTS (  WAIT TXA ; x,y-REG. retten (PHA (TYA (PHA (LDX #0FF ; Verzoegerung durch Probieren  WAIT1 LDY #02  WAIT2 DEY  BNE  B7UNTEN LDY BYTEZ ; laedt die unteren 8 Bit einer (LDA @ZP4,Y ; einfachen Druckzeile jeweils doppelt (STA BS0 (STA BS1 (LDA @ZP5,Y (STA BS2 (STA BS3 (LDA @ZP6,Y (STA BS4 (STA BS5 (LDA @ZP7,Y (STA BS6 (STA BS7  RTS   MAKB7OBEN LDY BYTEZ ; laedt die oberen 8 Bit einer (LDA @ZP0,Y ; Druckzeile jeweils doppelt (STA BS0 (STA BS1 (LDA @ZP1,Y (STA BS2 (STA BS3 (LDA @ZP2,Y (STA BS4 (STA BS5 (LDA @ZP3,Y (STA BS6 (STA BS7  RTS ( die uebereinanderstehenden (LDA @ZP0,Y ; 8 Byte auf Seite 0 (STA BS0 (LDA @ZP1,Y (STA BS1 (LDA @ZP2,Y (STA BS2 (LDA @ZP3,Y (STA BS3 (LDA @ZP4,Y (STA BS4 (LDA @ZP5,Y (STA BS5 (LDA @ZP6,Y (STA BS6 (LDA @ZP7,Y (STA BS7  RTS (  --> 7-Bit-Daten (RAUS 0D ; 'CR' (RAUS 0A ; 'LF' ( (PUSH RETURN (RTS ; zurueck nach PASCAL (  ;------------------------------  ; Unterprogramme  ;------------------------------   B7EINF LDY BYTEZ ; laedt zahl].rechts- 0satz[bildzahl].links-satz[1].rechts); &faktx := (satz[1].rechts - zentx)/(satz[bildzahl].rechts - zentx); &lnfx := (ln(faktx))/bildzahl; &zenty := (satz[1].unten*satz[bildzahl].oben - 0satz[bildzahl].unten*satz[1].oben)/ /(satz[1].unten+satz[bildzahl].oben- 0satz[bildzahl].unten-satz[1].oben); &fakty := (satz[1].oben - zenty)/(satz[bildzahl].oben - zenty); &lnfy := (ln(fakty))/bildzahl; $END; (* von letztes_bild *) " $PROCEDURE alle_anderen; $BEGIN &FOR zae"FOR zaehl1 := 1 TO bildzahl DO $BEGIN &eingabe; &berechnung; &ausgabe; $END;  END. (* Hauptprogramm, Version 2 *)  : file; &inout,zaehl1 : integer; "BEGIN $bild.adresse := 8192; $rewrite(f,filename); $inout := blockwrite(f,bild.zeiger^,16); $close(f,lock); "END;    $   BEGIN (* Hauptprogramm, Version 2 *) "sammeleingabe; setze(zaehl1,zaehl2); "UNTIL (zaehl2 = ypunkte) AND (zaehl1 = xpunkte);  END;  "PROCEDURE ausgabe; "TYPE $tbild = RECORD CASE boolean OF .true : (adresse : integer); .false : (zeiger : ^integer) ,END;  "VAR $bild : tbild;  &f er := unten + zaehl2 * deltay; $c_reell := links + zaehl1 * deltax; $xhoch2 := x * x; $yhoch2 := y * y; $fertig := false; $zaehl3 := 0; $REPEAT &f $UNTIL fertig; $IF (zaehl3 = anzahl) OR $((zaehl3 < grenze2) AND (zaehl3 MOD 3 = 0)) &THEN "zaehl2 := 0 ; "REPEAT $zaehl1 := succ(zaehl1); ${ IF keypress THEN sprung ELSE zaehl1 := succ(zaehl1); } $IF (zaehl1 > xpunkte) THEN &BEGIN (zaehl1 := 0; (zaehl2 := succ(zaehl2); &END; $x := xstart; $y := ystart; $c_imagina> grenze1) OR (zaehl3 = anzahl ) ;  END;  "  (* Version f}r zn+1 = zn2 - c *)  (* Apfelmaennchen *)  (* hier mit REPEAT-Schleife *)  BEGIN "deltax := (rechts-links)/xpunkte; "deltay := (oben-unten)/ypunkte; "zaehl1 := -1; eger; " PROCEDURE f;  (* Version f}r zn+1 = zn^2 - c *)  BEGIN "zaehl3 := succ(zaehl3); "y := 2.0 * x * y - c_imaginaer; "x := xhoch2 - yhoch2 - c_reell; "xhoch2 := x * x; "yhoch2 := y * y; "absqu := xhoch2 + yhoch2; "fertig := (absqu writeln(links:7:4,rechts:7:4,oben:7:4,unten:7:4,name); *END; $END; (* von alle_anderen *) & "BEGIN $erstes_bild; $letztes_bild; $alle_anderen; "END; (* von sammeleingabe *)    PROCEDURE berechnung; "VAR zaehl1,zaehl2,zaehl3 : int=(satz[bildzahl].ystart-satz[1].ystart)); ,grenze1 := 100.0; ,stelle[1] := chr(ord('A')+zaehl1); ,IF zaehl1 < 18 .THEN name := concat('#5:',filename,stelle,'.FOTO') .ELSE name := concat('#4:',filename,stelle,'.FOTO'); , := satz[1].grenze2+ trunc(zaehl1/bildzahl* =(satz[bildzahl].grenze2-satz[1].grenze2)); ,xstart := satz[1].xstart+ trunc(zaehl1/bildzahl* =(satz[bildzahl].xstart-satz[1].xstart)); ,ystart := satz[1].ystart+ trunc(zaehl1/bildzahl* atz[bildzahl].oben - zenty)* ;exp((bildzahl-zaehl1)*lnfy); ,unten := zenty + (satz[bildzahl].unten- zenty)* ;exp((bildzahl-zaehl1)*lnfy); ,anzahl := satz[1].anzahl + trunc(zaehl1/bildzahl* =(satz[bildzahl].anzahl-satz[1].anzahl)); ,grenze2 hl1 := 2 TO bildzahl DO (WITH satz[zaehl1] DO *BEGIN ,rechts := zentx + (satz[bildzahl].rechts - zentx)* ;exp((bildzahl-zaehl1)*lnfx); ,links := zentx + (satz[bildzahl].links - zentx)* ;exp((bildzahl-zaehl1)*lnfx); ,oben := zenty + (s